Servant with readerT

gistfile1.txt

{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}

module Main where

import GHC.Generics
import Data.Proxy
import Data.Monoid ((<>))

import Data.Aeson
import Network.Wai.Handler.Warp
import Servant

import Control.Monad.Reader

import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)
import Data.Text
import Data.Map

import qualified Data.Map as M

data Entry = Entry
  { entryId :: Int
  , entryText :: Text }
    deriving (Generic, Show)

data Config = Config
  { cOwner :: String
  , cStore :: Store 
  , cPort  :: Int }

type Store = TVar (Map Int Text)
instance FromJSON Entry
instance ToJSON Entry

type KeyVal = "entry" :> Get '[JSON] [Entry]
    :<|> "entry"
        :> ReqBody '[JSON] Text
        :> PostCreated '[JSON] Entry
    :<|> "entry"
        :> Capture "n" Int
        :> Get '[JSON] Entry
    :<|> "entry"
        :> Capture "n" Int
        :> DeleteNoContent '[JSON] NoContent

api :: Proxy KeyVal
api = Proxy

type AppT = ReaderT Store Handler
-- hmmmm
server :: ServerT KeyVal AppT
server = getAllEntries
    :<|> postEntry
    :<|> getEntry
    :<|> deleteEntry

-- | Define the handlers
getAllEntries :: AppT [Entry]
getAllEntries = do
    store  <- ask
    entries <- liftIO $ readTVarIO store
    return $ Prelude.map (uncurry Entry) (toList entries)

-- | Post entry handler
postEntry :: Text -> AppT Entry
postEntry text = do
    store <- ask
    liftIO $ atomically $ do
        entries <- readTVar store
        let key = if M.null entries then 1
                    else fst (findMax entries) + 1
        writeTVar store (insert key text entries)
        return (Entry key text)

-- | Get entry
getEntry :: Int -> AppT Entry
getEntry n = do
    store <- ask
    entries <- liftIO $ readTVarIO store
    case M.lookup n entries of
        Just text -> return (Entry n text)
        Nothing   -> throwError err400 { errBody = "Content not found" }
        
-- | Delete entry
deleteEntry :: Int -> AppT NoContent
deleteEntry n = do
    store <- ask
    liftIO $ atomically $
        modifyTVar' store (delete n)
    return NoContent

nt :: Store -> AppT a -> Handler a
nt s x = runReaderT x s

app :: Store -> Application
app s = serve api $ hoistServer api (nt s) server

main :: IO ()
main = do
    store <- newTVarIO M.empty
    let Config{..} = Config "Hiroto" store 8000
    putStrLn $ "Owner is " <> show cOwner
    putStrLn $ "Starting the server at " <> show cPort
    run cPort $ app cStore