Haskell Servant Persistent Example

Api.hs

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

module Api where

import Control.Monad.Reader (ReaderT, runReaderT)
import Control.Monad.Trans.Either (EitherT)
import Data.Int (Int64)
import Servant
import Config (Config(..))
import Models

type ReadingApi = "reads" :> Get '[JSON] [PReading]

type AppM = ReaderT Config (EitherT ServantErr IO)

readingApi :: Proxy ReadingApi
readingApi = Proxy

readerToEither :: Config -> AppM :~> EitherT ServantErr IO
readerToEither cfg = Nat $ \x -> runReaderT x cfg

Config.hs

{-# LANGUAGE OverloadedStrings #-}

module Config where

import Network.Wai.Middleware.RequestLogger (logStdoutDev, logStdout)
import Network.Wai                          (Middleware)
import Control.Monad.Logger                 (runNoLoggingT, runStdoutLoggingT)

import Database.Persist.Postgresql (ConnectionPool, createPostgresqlPool, ConnectionString)

data Config = Config
    { getPool :: ConnectionPool
    , getEnv  :: Environment
    }

data Environment =
    Development
  | Test
  | Production
  deriving (Eq, Show, Read)

defaultConfig :: Config
defaultConfig = Config
    { getPool = undefined
    , getEnv  = Development
    }

setLogger :: Environment -> Middleware
setLogger Test = id
setLogger Development = logStdoutDev
setLogger Production = logStdout

makePool :: Environment -> IO ConnectionPool
makePool Test = runNoLoggingT $ createPostgresqlPool (connStr Test) (envPool Test)
makePool e = runStdoutLoggingT $ createPostgresqlPool (connStr e) (envPool e)

envPool :: Environment -> Int
envPool Test = 1
envPool Development = 1
envPool Production = 8

connStr :: Environment -> ConnectionString
connStr Development = "host=localhost dbname=local user=local password=local port=5432"
connStr _ = undefined

dependencies.txt

tack list-dependencies
There were multiple candidates for the Cabal entry "Main.hs" (/Users/erewok/projects/test/Main.hs), picking /Users/erewok/projects/test/app/Main.hs
Warning: Directory listed in loretta.cabal file does not exist: test
MonadRandom 0.4.2.3
StateVar 1.1.0.4
adjunctions 4.3
aeson 0.9.0.1
aeson-compat 0.3.2.0
aeson-pretty 0.7.2
ansi-terminal 0.6.2.3
ansi-wl-pprint 0.6.7.3
appar 0.1.4
array 0.5.1.0
async 2.1.0
attoparsec 0.13.0.2
auto-update 0.1.3.1
base 4.8.2.0
base-compat 0.9.0
base-orphans 0.5.4
base-unicode-symbols 0.2.2.4
base64-bytestring 1.0.0.1
bifunctors 5.2
binary 0.7.5.0
blaze-builder 0.4.0.2
blaze-html 0.8.1.1
blaze-markup 0.7.0.3
byteorder 1.0.4
bytestring 0.10.6.0
bytestring-builder 0.10.6.0.0
bytestring-conversion 0.3.1
case-insensitive 1.2.0.6
charset 0.3.7.1
cmdargs 0.10.14
comonad 4.2.7.2
conduit 1.2.6.4
conduit-extra 1.1.13.1
containers 0.5.6.2
contravariant 1.4
cookie 0.4.2
cryptonite 0.15
data-default-class 0.0.1
deepseq 1.4.1.1
directory 1.2.2.0
distributive 0.5.0.2
dlist 0.7.1.2
double-conversion 2.0.1.0
easy-file 0.2.1
either 4.4.1
esqueleto 2.4.3
exceptions 0.8.2.1
fast-logger 2.4.6
file-embed 0.0.10
filepath 1.4.0.0
free 4.12.4
ghc-prim 0.4.0.0
hashable 1.2.4.0
hex 0.1.2
http-api-data 0.2.2
http-date 0.0.6.1
http-media 0.6.3
http-types 0.9
http2 1.4.5
integer-gmp 1.0.0.0
iproute 1.7.0
js-jquery 1.12.3
kan-extensions 4.2.3
lens 4.13
lifted-base 0.2.3.6
myreadingapp 0.1.0.0
lucid 2.9.5
memory 0.11
mime-types 0.1.0.7
mmorph 1.0.6
monad-control 1.0.1.0
monad-logger 0.3.18
monad-loops 0.4.3
mtl 2.2.1
nats 1.1
network 2.6.2.1
network-uri 2.6.1.0
old-locale 1.0.0.7
old-time 1.1.0.3
optparse-applicative 0.12.1.0
parallel 3.2.1.0
parsec 3.1.9
parsers 0.12.3
path-pieces 0.2.1
persistent 2.2.4.1
persistent-postgresql 2.2.2
persistent-template 2.1.8
postgresql-libpq 0.9.1.1
postgresql-simple 0.5.1.3
prelude-extras 0.4.0.3
primitive 0.6.1.0
process 1.2.3.0
profunctors 5.2
psqueues 0.2.2.1
random 1.1
reflection 2.1.2
resource-pool 0.2.3.2
resourcet 1.1.7.3
safe 0.3.9
scientific 0.3.4.6
semigroupoids 5.0.1
semigroups 0.18.1
servant 0.4.4.7
servant-docs 0.4.4.7
servant-lucid 0.4.4.7
servant-server 0.4.4.7
silently 1.2.5
simple-sendfile 0.2.21
split 0.2.3
stm 2.4.4.1
stm-chans 3.0.0.4
streaming-commons 0.1.15.4
string-conversions 0.4
stringsearch 0.3.6.6
syb 0.6
system-filepath 0.4.13.4
tagged 0.8.4
template-haskell 2.10.0.0
text 1.2.2.1
time 1.5.0.1
time-locale-compat 0.1.1.1
transformers 0.4.2.0
transformers-base 0.4.4
transformers-compat 0.4.0.4
unix 2.7.1.0
unix-compat 0.4.1.4
unix-time 0.3.6
unordered-containers 0.2.5.1
utf8-string 1.0.1.1
uuid-types 1.0.3
vault 0.3.0.6
vector 0.11.0.0
void 0.7.1
wai 3.2.1
wai-app-static 3.1.5
wai-cors 0.2.4
wai-extra 3.0.15.1
wai-logger 2.2.7
warp 3.2.2
word8 0.1.2
zlib 0.6.1.1

Handlers.hs

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

module Handlers where

import Data.Aeson (toJSON)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (lift)
import Control.Monad.Trans.Either (left)
import Data.Time (UTCTime, getCurrentTimeZone, utcToLocalTime)
import Network.Wai (Application)
import Database.Persist.Postgresql (get, selectList, Entity(..),
                                    insert, (==.), toSqlKey, fromSqlKey)
import Data.Int (Int64)
import Servant
import Api
import Config (Config(..))
import Models


app :: Config -> Application
app cfg = serve readingApi (readerServer cfg)

readingServer :: ServerT ReadingApi AppM
readingServer = allReadings

readerServer :: Config -> Server ReadingApi
readerServer cfg = enter (readerToEither cfg) readingServer


allReadings :: AppM [PReading]
allReadings = do
  readings <- runDb $ selectList [] []
  let results = map (\(Entity _ a) -> readingOutput a) readings
  liftIO $ sequence results

Models.hs

{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE DeriveGeneric              #-}

module Models where

import Data.Aeson                  (ToJSON, FromJSON)
import Data.Int                    (Int64)
import Data.Time                   (UTCTime, LocalTime, getCurrentTimeZone, utcToLocalTime)
import GHC.Generics                (Generic)
import Control.Monad.Reader        (Reader, ReaderT, asks, liftIO)
import Control.Monad.Trans         (MonadIO)
import Database.Persist.Postgresql
import Database.Persist.TH         (share, mkPersist, sqlSettings,
                                    mkMigrate, persistLowerCase)

import Config

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Reading json
    diastolic Int
    systolic Int
    timestamp UTCTime default=now()
|]

data PReading = PReading {
  diastolic :: Int
  , systolic :: Int
  , datetime :: LocalTime
  } deriving (Eq, Show, Generic)

instance ToJSON PReading
instance FromJSON PReading

readingOutput :: Reading -> IO PReading
readingOutput Reading{..} = do
  tz <- getCurrentTimeZone
  return $ PReading {
    diastolic = readingDiastolic
    , systolic = readingSystolic
    , datetime = utcToLocalTime tz readingTimestamp}



doMigrations :: ReaderT SqlBackend IO ()
doMigrations = runMigration migrateAll

runDb query = do
    pool <- asks getPool
    liftIO $ runSqlPool query pool