Typed up CRUD SPA with Haskell and Elm - Part 2: Persistence up and running

  build-depends:
    -- ...
    ,  wai-cors
    -- ...

;....

import Network.Wai.Middleware.Cors

;....

albumCors :: Middleware
albumCors = cors $ const (Just albumResourcePolicy)                             (1)


albumResourcePolicy :: CorsResourcePolicy                                       (2)
albumResourcePolicy =
    CorsResourcePolicy
        { corsOrigins = Nothing -- gives you /*
        , corsMethods = ["GET", "POST", "PUT", "DELETE", "HEAD", "OPTION"]
        , corsRequestHeaders = simpleHeaders -- adds "Content-Type" to defaults
        , corsExposedHeaders = Nothing
        , corsMaxAge = Nothing
        , corsVaryOrigin = False
        , corsRequireOrigin = False
        , corsIgnoreFailures = False
        }


main :: IO ()
main = do
  run 8081 $ albumCors $ app                                                    (3)

  build-depends:
    -- ...
    , sqlite-simple
    -- ...

{-# LANGUAGE OverloadedStrings #-}
module Main where


import qualified Storage as S                              (1)
import qualified Api as A                                  (2)
import Network.Wai
import Network.Wai.Handler.Warp
import Servant
import Network.Wai.Middleware.Cors
import Control.Exception (bracket)
import Database.SQLite.Simple as Sql


app :: Sql.Connection -> Application
app conn = serve A.api (A.artistsServer conn)              (3)


testConnect :: IO Sql.Connection
testConnect = Sql.open ":memory:"                          (4)


withTestConnection :: (Sql.Connection -> IO a) -> IO a
withTestConnection cb =                                    (5)
  withConn $ \conn -> cb conn
  where
    withConn = bracket testConnect Sql.close               (6)

{-
  ...
  cors stuff omitted, already covered
-}


main :: IO ()
main = do
  withTestConnection $ \conn ->  do
    S.bootstrapDB conn                                     (7)
    run 8081 $ albumCors $ app conn                        (8)

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

module Api where

import qualified Model as M                           (1)
import qualified Storage as S
import Data.Aeson
import Control.Monad.IO.Class     (MonadIO, liftIO)
import Control.Monad.Trans.Either
import Servant
import Database.SQLite.Simple as Sql


instance ToJSON M.Artist
instance FromJSON M.Artist


type ArtistAPI =                                       (2)
       Get '[JSON] [M.Artist]
  :<|> ReqBody '[JSON] M.Artist :> Post '[JSON] M.Artist
  :<|> Capture "artistId" Int :> Get '[JSON] M.Artist
  :<|> Capture "artistId" Int :> ReqBody '[JSON] M.Artist :> Put '[JSON] M.Artist
  :<|> Capture "artistId" Int :> Delete '[] ()

-- '

artistsServer :: Sql.Connection -> Server ArtistAPI    (3)
artistsServer conn =
  getArtists :<|> postArtist :<|> getArtist :<|>  updateArtist :<|> deleteArtist

  where
    getArtists                   = liftIO $ S.findArtists conn     (4)
    getArtist artistId           = liftIOMaybeToEither err404 $ S.artistById conn artistId
    postArtist artist            = liftIO $ S.newArtist conn artist
    updateArtist artistId artist = liftIO $ S.updateArtist conn artist artistId
    deleteArtist artistId        = liftIO $ S.deleteArtist conn artistId


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


type API = "artists" :> ArtistAPI


api :: Proxy API
api = Proxy

{-# LANGUAGE DeriveGeneric #-}

module Model where

import GHC.Generics

data Artist = Artist                (1)
  { artistId :: Maybe Int           (2)
  , artistName :: String            (3)
  } deriving (Eq, Show, Generic)

{-# LANGUAGE OverloadedStrings #-}
module Storage where


import qualified Model as M
import qualified Data.Text as Txt


import Database.SQLite.Simple as Sql
import Database.SQLite.Simple.Types as SqlTypes


instance Sql.FromRow M.Artist where                         (1)
  fromRow = M.Artist <$> Sql.field <*> Sql.field



artistById :: Sql.Connection -> Int -> IO (Maybe M.Artist)  (2)
artistById conn idParam =
  findById conn "artist" idParam :: IO (Maybe M.Artist)


findArtists :: Sql.Connection -> IO [M.Artist]
findArtists conn =
  Sql.query_ conn "select * from artist" :: IO [M.Artist]


newArtist :: Sql.Connection -> M.Artist -> IO M.Artist
newArtist conn artist = do
  Sql.execute conn "insert into artist (name) values (?) " (Sql.Only $ M.artistName artist)
  rawId <- lastInsertRowId conn
  let updArtist = artist { M.artistId = Just (fromIntegral rawId) }  (3)
  return updArtist


-- Really we should check whether the artist exists here
updateArtist :: Sql.Connection -> M.Artist -> Int -> IO M.Artist
updateArtist conn artist idParam = do
  Sql.executeNamed conn "update artist set name = :name where id = :id" params
  return artist { M.artistId = Just idParam }                        (4)
  where
    params = [":id" := (idParam :: Int), ":name" := ((M.artistName artist) :: String)]


deleteArtist :: Sql.Connection -> Int -> IO ()
deleteArtist conn idParam =
  Sql.execute conn "delete from artist where id = ?" (Sql.Only idParam)


findById :: (FromRow a) => Sql.Connection -> String -> Int -> IO (Maybe a)
findById conn table idParam = do
  rows <- Sql.queryNamed conn (createFindByIdQuery table) [":id" := (idParam :: Int)]
  let result = case (length rows) of
                  0 -> Nothing
                  _ -> Just $ head rows      (5)

  return result


createFindByIdQuery :: String -> SqlTypes.Query
createFindByIdQuery table =
  SqlTypes.Query $ Txt.pack $ "SELECT * from " ++ table ++ " where id = :id"   (6)

-- ... boostrap function left out, check the source repo for details