Servant-like handlers router for Telegram bots

TelegramHandlersRouter.hs

{-# LANGUAGE DataKinds, TypeOperators #-}
{-# LANGUAGE TypeFamilies, FlexibleInstances, FlexibleContexts, ScopedTypeVariables
  #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE InstanceSigs #-}

module Router where

import Control.Applicative
import Control.Monad
import Data.Maybe
import Data.Proxy
import Data.Typeable

type family RouteParser a :: *

data a :<|> b =
  a :<|> b

infixr 8 :<|>

type instance RouteParser (a :<|> b) =
     RouteParser a :<|> RouteParser b

-- Embedded route operators
newtype HandlerPrivateChatMessage (a :: *) =
  HandlerPrivateChatMessage a
  deriving (Show)

type instance RouteParser (HandlerPrivateChatMessage a) = a -> IO a

newtype HandlerInlineButtonClick (a :: *) =
  HandlerInlineButtonClick a
  deriving (Show)

type instance RouteParser (HandlerInlineButtonClick a) = a -> IO a

class Router a where
  route :: (Typeable a, Typeable payload) => Proxy a -> RouteParser a -> payload -> Maybe (IO ())

instance (Typeable a, Typeable b, Router a, Router b) => Router (a :<|> b) where
  route :: (Typeable payload) => Proxy (a :<|> b) -> RouteParser (a :<|> b) -> payload -> Maybe (IO ())
  route _ (handlerLeft :<|> handlerRight) payload =
    route (Proxy :: Proxy a) handlerLeft payload <|>
    route (Proxy :: Proxy b) handlerRight payload

instance (Typeable a) => Router (HandlerPrivateChatMessage a) where
  route :: (Typeable payload) => Proxy (HandlerPrivateChatMessage a) -> (a -> IO a) -> payload -> Maybe (IO ())
  route _ handler payload = case (cast payload :: Maybe a) of 
    Nothing -> Nothing
    Just p -> Just $ void $ handler p

instance (Typeable a) => Router (HandlerInlineButtonClick a) where
  route :: (Typeable payload) => Proxy (HandlerInlineButtonClick a) -> (a -> IO a) -> payload -> Maybe (IO ())
  route _ handler payload = case (cast payload :: Maybe a) of 
    Nothing -> Nothing
    Just p -> Just $ void $ handler p

serve :: (Router a, Typeable a, Typeable payload) => Proxy a -> RouteParser a -> payload -> IO ()
serve p handler payload = fromMaybe (putStrLn "error") (route p handler payload)

{-
-- Example

-- Define your own API like you do it in Servant:
type MyAPI
   = HandlerPrivateChatMessage String :<|> HandlerInlineButtonClick Int

handlerOfMessages :: String -> IO String
handlerOfMessages a = putStr ("incoming message " ++ show a) >> return a
handlerOfInlineButtonClicks :: Int -> IO Int
handlerOfInlineButtonClicks a = putStr ("incoming inline button " ++ show a) >> return a

handlerMyAPI :: RouteParser MyAPI
handlerMyAPI = handlerOfMessages :<|> handlerOfInlineButtonClicks

-- Than in GHCi run the example:
ghci> serve (Proxy :: Proxy MyAPI) handlerMyAPI "String here"
incoming message "String here"
ghci> serve (Proxy :: Proxy MyAPI) handlerMyAPI (42 :: Int)
incoming inline button 42
 -}