Config.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}

module Lib.Config (
    ApiInfo(..)
    , Config(..)
    , TnConfig(..)
    , TnOptions(..)
    , TnIO
    , parseConfig
    , apiInfo
    ) where

import Servant
import Database.RethinkDB                           (RethinkDBHandle)
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Control.Monad.Trans
import Network.Socket                               (HostName)
import GHC.Generics
import Data.Text.Lazy
import System.Console.CmdArgs
import Data.Aeson
import Data.Pool
import qualified Data.Text as T
import qualified Data.Configurator as C

data ApiInfo = ApiInfo {
  name :: T.Text,
  version :: T.Text
} deriving (Eq, Generic)

instance FromJSON ApiInfo
instance ToJSON ApiInfo

data Config = Config {
   info :: ApiInfo
   , dbHost :: HostName
   , port :: Int
   }

data TnConfig = TnConfig {
    pool :: (Pool RethinkDBHandle)
    , config :: Config
    }

data TnOptions = TnOptions {
    env :: String
    } deriving (Data,Typeable)

type TnEnv = String
type TnIO = ReaderT TnConfig (ExceptT ServantErr IO)

parseConfig :: TnEnv -> Text -> IO Config
parseConfig e t = do
    let env = pack e
        dh = env `append` ".database.host"
        pt = env `append` t `append` ".port"

    cfg <- C.load [C.Required "trainerninja.cfg"]
    v <- C.require cfg "version"
    h <- C.require cfg (T.pack $ unpack dh)
    p <- C.require cfg (T.pack $ unpack pt)
    let apiInfo = ApiInfo "Trainerninja API" v
    return $ Config apiInfo h p

apiInfo :: TnIO ApiInfo
apiInfo = do
    TnConfig _ c <- ask
    return $ info c

Main.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}

import Servant
import Data.Monoid ((<>))
import Data.Either.Unwrap (fromRight)
import Data.Text (Text)
import System.Console.CmdArgs
import Data.Text.Lazy (pack)
import Network.Wai.Handler.Warp (run)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except
import Control.Monad.Trans.Either
import Control.Monad.Trans.Reader
import Data.Functor.Identity
import qualified Data.ByteString.Lazy.Char8 as BL

import Lib.Config
import Lib.RethinkDB
import Model.Types.User (SecureUser)
import Model.Types.UserSignup (UserSignup)
import Model.User

type API = Get '[JSON] ApiInfo
    :<|> "users" :> Get '[JSON] [SecureUser]
    :<|> "users" :> ReqBody '[JSON] UserSignup :> Post '[JSON] SecureUser

api :: Proxy API
api = Proxy

serverT :: TnConfig -> ServerT API TnIO
serverT t = getApiInfo
    :<|> getUsers
    :<|> postUsers
    where
        getApiInfo :: TnIO ApiInfo
        getApiInfo = apiInfo

        getUsers :: TnIO [SecureUser]
        getUsers = list

        postUsers :: UserSignup -> TnIO SecureUser
        postUsers u = do
            eitherU <- create u
            return $ fromRight eitherU

tnIOToEither' :: TnConfig -> forall a. TnIO a -> EitherT ServantErr IO a
tnIOToEither' t r = EitherT (fmap Right (runReaderT r t))
-- Api/Main.hs:50:55:
--    Couldn't match type ‘ExceptT ServantErr IO’ with ‘IO’
--    Expected type: ReaderT TnConfig IO a
--      Actual type: TnIO a
--    In the first argument of ‘runReaderT’, namely ‘r’
--    In the second argument of ‘fmap’, namely ‘(runReaderT r t)’

tnIOToEither :: TnConfig -> TnIO :~> EitherT ServantErr IO
tnIOToEither t = Nat $ readerToEither' t

server :: TnConfig -> Server API
server t = enter (tnIOToEither t) (serverT t)

main :: IO ()
main = do
    -- setup environment
    args <- cmdArgs $ TnOptions "development"

    -- Config
    p <- createRethinkPool "localhost"
    cfg <- parseConfig (env args) (pack ".api")
    let dbh = dbHost cfg

    -- DB
    p <- createRethinkPool dbh
    let tn = TnConfig p cfg

    -- RethinkDB setup
    setupDB dbh

    putStrLn $ "Running on " <> show 3001
    run 3001 $ serve api $ server tn