|
| 1 | +# Overview |
| 2 | + |
| 3 | +This doc will walk through a single-module implementation of a servant API connecting to a MySQL database. It will also include some basic CRUD operations. |
| 4 | + |
| 5 | +Once you can wrap your head around this implemenation, understanding more complex features like resource pools would be beneficial next steps. |
| 6 | + |
| 7 | +The only *prerequisite* is that you have a MySQL database open on port 3306 of your machine. Docker is an easy way to manage this. |
| 8 | + |
| 9 | +## Setup |
| 10 | + |
| 11 | +- The mysql database should be up and running on 127.0.0.1:3306 |
| 12 | + |
| 13 | +- Our API will be exposed on localhost:8080 |
| 14 | + |
| 15 | +## REST actions available |
| 16 | + |
| 17 | +*Get all people* |
| 18 | + |
| 19 | +``` |
| 20 | +/people GET |
| 21 | +``` |
| 22 | +
|
| 23 | +*Get person by ID* |
| 24 | +
|
| 25 | +``` |
| 26 | +/people/:id GET |
| 27 | +``` |
| 28 | +
|
| 29 | +*Insert a new person* |
| 30 | +
|
| 31 | +``` |
| 32 | +/people POST |
| 33 | +
|
| 34 | +{ |
| 35 | + "name": "NewName", |
| 36 | + "age": 24 |
| 37 | +} |
| 38 | +``` |
| 39 | +
|
| 40 | +*Delete a person* |
| 41 | +
|
| 42 | +``` |
| 43 | +/people/:id DELETE |
| 44 | +``` |
| 45 | +
|
| 46 | +## Other notes |
| 47 | +
|
| 48 | +At the time of writing this issue may occur when building your project: |
| 49 | +
|
| 50 | +``` |
| 51 | +setup: Missing dependencies on foreign libraries: |
| 52 | +* Missing (or bad) C libraries: ssl, crypto |
| 53 | +``` |
| 54 | +
|
| 55 | +If using stack, this can be fixed by adding the following lines to your `stack.yaml`: |
| 56 | +
|
| 57 | +``` |
| 58 | +extra-include-dirs: |
| 59 | +- /usr/local/opt/openssl/include |
| 60 | +extra-lib-dirs: |
| 61 | +- /usr/local/opt/openssl/lib |
| 62 | +``` |
| 63 | +
|
| 64 | +Or for cabal, running your builds with these configurations passed as options. |
| 65 | +
|
| 66 | +## Implementation: Main.hs |
| 67 | +
|
| 68 | +Let's jump in: |
| 69 | +
|
| 70 | +```haskell |
| 71 | +{-# LANGUAGE DataKinds #-} |
| 72 | +{-# LANGUAGE DeriveGeneric #-} |
| 73 | +{-# LANGUAGE FlexibleInstances #-} |
| 74 | +{-# LANGUAGE GADTs #-} |
| 75 | +{-# LANGUAGE GeneralizedNewtypeDeriving #-} |
| 76 | +{-# LANGUAGE MultiParamTypeClasses #-} |
| 77 | +{-# LANGUAGE QuasiQuotes #-} |
| 78 | +{-# LANGUAGE TemplateHaskell #-} |
| 79 | +{-# LANGUAGE TypeFamilies #-} |
| 80 | +{-# LANGUAGE TypeOperators #-} |
| 81 | +module Lib where |
| 82 | +
|
| 83 | +import Control.Monad.IO.Class (liftIO) |
| 84 | +import Control.Monad.Logger (NoLoggingT (..)) |
| 85 | +import Control.Monad.Trans.Reader (runReaderT) |
| 86 | +import Control.Monad.Trans.Resource (ResourceT, runResourceT) |
| 87 | +import Data.Aeson as JSON |
| 88 | +import Data.Int (Int64 (..)) |
| 89 | +import Data.Text (Text) |
| 90 | +import qualified Data.Text as T |
| 91 | +import qualified Data.Text.IO as T |
| 92 | +import Database.Persist |
| 93 | +import Database.Persist.MySQL (ConnectInfo (..), |
| 94 | + SqlBackend (..), |
| 95 | + defaultConnectInfo, fromSqlKey, runMigration, |
| 96 | + runSqlPool, toSqlKey, withMySQLConn) |
| 97 | +import Database.Persist.Sql (SqlPersistT, runSqlConn) |
| 98 | +import Database.Persist.TH (mkMigrate, mkPersist, |
| 99 | + persistLowerCase, share, |
| 100 | + sqlSettings) |
| 101 | +import Database.Persist.Types (PersistValue(PersistInt64)) |
| 102 | +import Servant (Handler, throwError) |
| 103 | +
|
| 104 | +import GHC.Generics |
| 105 | +import Network.Wai |
| 106 | +import Network.Wai.Handler.Warp |
| 107 | +import Servant |
| 108 | +import Servant.API |
| 109 | +import System.Environment (getArgs) |
| 110 | +
|
| 111 | +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| |
| 112 | +Person json |
| 113 | + Id Int Primary Unique |
| 114 | + name Text |
| 115 | + age Text |
| 116 | + deriving Eq Show Generic |
| 117 | +|] |
| 118 | +
|
| 119 | +type Api = |
| 120 | + "person" :> Get '[JSON] [Person] |
| 121 | + :<|> "person" :> Capture "id" Int :> Get '[JSON] Person |
| 122 | + :<|> "person" :> Capture "id" Int :> Delete '[JSON] () |
| 123 | + :<|> "person" :> ReqBody '[JSON] Person :> Post '[JSON] Person |
| 124 | + |
| 125 | +apiProxy :: Proxy Api |
| 126 | +apiProxy = Proxy |
| 127 | + |
| 128 | +app :: Application |
| 129 | +app = serve apiProxy server |
| 130 | + |
| 131 | +-- Run a database operation, and lift the result into a Handler. |
| 132 | +-- This minimises usage of IO operations in other functions |
| 133 | +runDB :: SqlPersistT (ResourceT (NoLoggingT IO)) a -> Handler a |
| 134 | +runDB a = liftIO $ runNoLoggingT $ runResourceT $ withMySQLConn connInfo $ runSqlConn a |
| 135 | + |
| 136 | +-- Change these out to suit your local setup |
| 137 | +connInfo :: ConnectInfo |
| 138 | +connInfo = defaultConnectInfo { connectHost = "127.0.0.1", connectUser = "root", connectPassword = "abcd", connectDatabase = "test-database" } |
| 139 | + |
| 140 | +doMigration :: IO () |
| 141 | +doMigration = runNoLoggingT $ runResourceT $ withMySQLConn connInfo $ runReaderT $ runMigration migrateAll |
| 142 | + |
| 143 | +server :: Server Api |
| 144 | +server = |
| 145 | + personGET :<|> |
| 146 | + personGETById :<|> |
| 147 | + personDELETE :<|> |
| 148 | + personPOST |
| 149 | + where |
| 150 | + personGET = selectPersons |
| 151 | + personGETById id = selectPersonById id |
| 152 | + personDELETE id = deletePerson id |
| 153 | + personPOST personJson = createPerson personJson |
| 154 | + |
| 155 | +selectPersons :: Handler [Person] |
| 156 | +selectPersons = do |
| 157 | + personList <- runDB $ selectList [] [] |
| 158 | + return $ map (\(Entity _ u) -> u) personList |
| 159 | +
|
| 160 | +selectPersonById :: Int -> Handler Person |
| 161 | +selectPersonById id = do |
| 162 | + sqlResult <- runDB $ get $ PersonKey id |
| 163 | + case sqlResult of |
| 164 | + Just person -> return person |
| 165 | + Nothing -> throwError err404 { errBody = JSON.encode "Person with ID not found." } |
| 166 | +
|
| 167 | +createPerson :: Person -> Handler Person |
| 168 | +createPerson person = do |
| 169 | + attemptCreate <- runDB $ insert person |
| 170 | + case attemptCreate of |
| 171 | + PersonKey k -> return person |
| 172 | + _ -> throwError err503 { errBody = JSON.encode "Could not create Person." } |
| 173 | +
|
| 174 | +deletePerson :: Int -> Handler () |
| 175 | +deletePerson id = do runDB $ delete $ PersonKey id |
| 176 | +
|
| 177 | +startApp :: IO () |
| 178 | +startApp = do |
| 179 | + args <- getArgs |
| 180 | + let arg1 = if not (null args) then Just (head args) else Nothing |
| 181 | + case arg1 of |
| 182 | + Just "migrate" -> doMigration |
| 183 | + _ -> run 8080 app |
| 184 | +``` |
| 185 | +
|
| 186 | +## Sample requests |
| 187 | +
|
| 188 | +Assuming that you have the db running and have first run `stack exec run migrate`, the following sample requests will test your API: |
| 189 | +
|
| 190 | +*Create a person* |
| 191 | +
|
| 192 | +```bash |
| 193 | +curl -X POST \ |
| 194 | + http://localhost:8080/person \ |
| 195 | + -H 'Accept: */*' \ |
| 196 | + -H 'Accept-Encoding: gzip, deflate' \ |
| 197 | + -H 'Cache-Control: no-cache' \ |
| 198 | + -H 'Connection: keep-alive' \ |
| 199 | + -H 'Content-Length: 62' \ |
| 200 | + -H 'Content-Type: application/json' \ |
| 201 | + -H 'Host: localhost:8080' \ |
| 202 | + -H 'cache-control: no-cache' \ |
| 203 | + -d '{ |
| 204 | + "name": "Jake", |
| 205 | + "age": "25" |
| 206 | +}' |
| 207 | +``` |
| 208 | +
|
| 209 | +*Get all persons* |
| 210 | +
|
| 211 | +```bash |
| 212 | +curl -X GET \ |
| 213 | + http://localhost:8080/person \ |
| 214 | + -H 'Accept: */*' \ |
| 215 | + -H 'Accept-Encoding: gzip, deflate' \ |
| 216 | + -H 'Cache-Control: no-cache' \ |
| 217 | + -H 'Connection: keep-alive' \ |
| 218 | + -H 'Content-Length: 33' \ |
| 219 | + -H 'Content-Type: application/json' \ |
| 220 | + -H 'Host: localhost:8080' \ |
| 221 | + -H 'cache-control: no-cache' |
| 222 | +``` |
| 223 | +
|
| 224 | +*Get person by ID* |
| 225 | +
|
| 226 | +```bash |
| 227 | +curl -X GET \ |
| 228 | + http://localhost:8080/person/1 \ |
| 229 | + -H 'Accept: */*' \ |
| 230 | + -H 'Accept-Encoding: gzip, deflate' \ |
| 231 | + -H 'Cache-Control: no-cache' \ |
| 232 | + -H 'Connection: keep-alive' \ |
| 233 | + -H 'Content-Type: application/json' \ |
| 234 | + -H 'Host: localhost:8080' \ |
| 235 | + -H 'cache-control: no-cache' |
| 236 | +``` |
0 commit comments