Created
July 8, 2015 18:27
-
-
Save seanhess/b17d4e3da88080c35542 to your computer and use it in GitHub Desktop.
Haskell Servant ReaderT ExceptT newtype monad transformer stack
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# LANGUAGE OverloadedStrings #-} | |
{-# LANGUAGE TypeOperators #-} | |
{-# LANGUAGE DataKinds #-} | |
{-# LANGUAGE PolyKinds #-} | |
{-# LANGUAGE GeneralizedNewtypeDeriving #-} | |
module Serials.Route.Test where | |
import Control.Monad.Trans (lift) | |
import Control.Monad.Trans.Either | |
import Control.Monad.Except | |
import Control.Monad.Reader | |
import Control.Monad.IO.Class (liftIO, MonadIO) | |
import Data.Monoid | |
import Data.Text (Text, pack) | |
import Data.Text.Lazy (fromStrict) | |
import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) | |
import Data.Aeson | |
import Data.ByteString.Lazy (ByteString) | |
import Servant.Server | |
import Servant | |
import Database.RethinkDB.NoClash | |
import System.Environment | |
data AppError = Invalid Text | NotFound | ServerError Text | |
newtype App a = App { | |
runApp :: ReaderT Int (ExceptT AppError IO) a | |
} deriving (Monad, Functor, Applicative, MonadReader Int, MonadError AppError, MonadIO) | |
type TestAPI = | |
"a" :> Get '[JSON] String | |
:<|> "b" :> Get '[JSON] String | |
:<|> "c" :> Get '[JSON] String | |
giveMeAMessage :: App String | |
giveMeAMessage = do | |
code <- ask | |
name <- getProgName' | |
throwError $ Invalid "Goooo" | |
return $ show code <> name | |
testWoot :: App (Maybe String) | |
testWoot = return $ Nothing | |
testErr :: App (Either String String) | |
testErr = return $ Left "Oh no!" | |
getProgName' :: MonadIO m => m String | |
getProgName' = liftIO $ getProgName | |
woot :: IO String | |
woot = return "hello" | |
--------------------------------------------------------------- | |
-- return a 404 if Nothing | |
isNotFound :: App (Maybe a) -> App a | |
isNotFound action = do | |
res <- action | |
case res of | |
Nothing -> throwError $ NotFound | |
Just v -> return v | |
-- map to a generic error | |
isError :: Show e => App (Either e a) -> App a | |
isError action = do | |
res <- action | |
case res of | |
Left e -> throwError $ ServerError $ pack $ show e | |
Right v -> return v | |
-- wow, it's IN My monad here! that's swell | |
testServerT ::ServerT TestAPI App | |
testServerT = getA :<|> getB :<|> getC | |
where | |
getA :: App String | |
getA = giveMeAMessage | |
-- you can also lift IO functions | |
--getA = liftIO $ woot | |
-- I can map app functions that return Maybes and Eithers to | |
-- app exceptions using little functions like this | |
getB :: App String | |
getB = isNotFound $ testWoot | |
getC :: App String | |
getC = isError $ testErr | |
-- see this is awesome because I can easily map error codes here | |
-- especially if they are different types? | |
runAppT :: Int -> App a -> EitherT ServantErr IO a | |
runAppT code action = do | |
res <- liftIO $ runExceptT $ runReaderT (runApp action) code | |
-- branch based on the error or value | |
EitherT $ return $ case res of | |
Left (Invalid text) -> Left err400 { errBody = textToBSL text } | |
Left (NotFound) -> Left err404 | |
Left (ServerError text) -> Left err500 { errBody = textToBSL text } | |
Right a -> Right a | |
textToBSL :: Text -> ByteString | |
textToBSL = encodeUtf8 . fromStrict | |
testServer' :: Int -> Server TestAPI | |
testServer' code = enter (Nat $ (runAppT code)) testServerT |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment