Composable routes in servant

ServantHelpers.hs

module ServantHelpers(Server,Proxy(..),err400, err404,liftIO,liftIOMaybeToEither) where

import Control.Monad.IO.Class     (MonadIO, liftIO)
import Control.Monad.Trans.Either (EitherT, left, right)
import Servant(ServantErr,Proxy(..))
import Servant.Server


liftIOMaybeToEither ::  (MonadIO m) => a -> IO (Maybe b) -> EitherT a m b
liftIOMaybeToEither err x = do
    m <- liftIO x
    case m of
      Nothing -> left err
      Just x -> right x

StorageServer.hs

{-# LANGUAGE DataKinds     #-}
{-# LANGUAGE TypeOperators #-}

module StorageServer where

import           Models
import           Servant.API
import           ServantHelpers
import           StorageDB

type ProjectAPI  =  Get '[JSON] ProjectList
               :<|> Capture "pId" ProjectId :> Get '[JSON] Project
               :<|> ReqBody '[JSON] Project :> Post '[JSON] Project
               :<|> Capture "pId" ProjectId :> Delete '[JSON] ProjectId

type TenantAPI  =  Get '[JSON] Tenants
              :<|> Capture "tId" TenantId :> Get '[JSON] Tenant
              :<|> ReqBody '[JSON] Tenant :> Post '[JSON] Tenant
              :<|> Capture "tId" TenantId :> Delete '[JSON] TenantId
              :<|> Capture "tId" TenantId :> "projects" :> ProjectAPI

type AdminAPI = "builddatabase" :> Get '[JSON] String

type StorageAPI =  "tenants" :> TenantAPI
              :<|> "admin"   :> AdminAPI

projectServer :: TenantId -> Server ProjectAPI
projectServer tId =
               liftIO (getProjectListForTenant tId)
          :<|> liftIOMaybeToEither err404 . findProject tId
          :<|> liftIOMaybeToEither err400 . insertProject
          :<|> liftIO . deleteProject tId

tenantServer :: Server TenantAPI
tenantServer =
               liftIO getTenants
          :<|> liftIOMaybeToEither err404 . findTenant
          :<|> liftIOMaybeToEither err400 . insertTenant
          :<|> liftIO . deleteTenant
          :<|> projectServer

adminServer :: Server AdminAPI
adminServer = liftIO buildDatabase

storageAPI :: Proxy StorageAPI
storageAPI = Proxy

storageServer :: Server StorageAPI
storageServer = tenantServer :<|> adminServer


-- $ curl -H "Content-Type: application/json" -X POST -d '{"tenantId":1,"tenantName":"facebook"}' http://localhost:8081/tenants/
-- {"tenantName":"facebook","tenantId":2}
-- $ curl -H "Content-Type: application/json" -X POST -d '{"projectId":1,"projectTenantId":1,"projectDescription":"a project","projectContent"
-- :"some value"}' http://localhost:8081/tenants/1/projects
-- {"projectTenantId":1,"projectContent":"some value","projectId":1,"projectDescription":"a project"}