ElmTut.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Main where

import Data.Aeson
import Data.Proxy
import GHC.Generics
import Servant.API

import Data.Swagger (Swagger, ToSchema)
import Control.Concurrent (forkIO, MVar, newEmptyMVar, takeMVar, putMVar, readMVar, newMVar)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (throwE)
import Network.Wai (Application)
import Network.Wai.Handler.Warp (runSettings, setPort, setBeforeMainLoop, defaultSettings)
import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.RequestLogger (logStdoutDev)
import Servant
import Servant.Swagger
import System.IO
import qualified Data.Map as M
import Servant.Swagger.UI

-- | Swagger schema endpoint
type SwaggerSchemaEndpoint = "swagger.js" :> Get '[JSON] Swagger

-- | Unhabitated new data type, to be able to refer to API type from the API type.
data API

-- | Underlying API type
type API'
    = SwaggerSchemaEndpoint
 :<|> SwaggerUI "ui" SwaggerSchemaEndpoint API
 :<|> Api

instance HasServer API context where
  type ServerT API m = ServerT API' m
  route _ = route (Proxy :: Proxy API')

type instance IsElem' e API = IsElem e API'

swaggerDoc :: Swagger
swaggerDoc = toSwagger (Proxy :: Proxy Api)

serverWithSwagger :: Server Api -> Server API
serverWithSwagger s
    = pure swaggerDoc
 :<|> swaggerUIServer
 :<|> s

type Api =
  "api" :>
    ("player" :> Get '[JSON] [Player] :<|>
     "player" :> Capture "playerId" PlayerId :> Get '[JSON] Player :<|>
     "player" :> Capture "playerId" PlayerId :> ReqBody '[JSON] Player :> Post '[JSON] Player :<|>
     "player" :> Capture "playerId" PlayerId :> ReqBody '[JSON] Player :> Put '[JSON] Player)

api :: Proxy Api
api = Proxy

type PlayerId = Integer

data Player
  = Player {
    playerId :: PlayerId,
    playerName :: String,
    playerLevel :: Integer
  }
  deriving (Eq, Show, Generic)

instance ToSchema Player

instance ToJSON Player
instance FromJSON Player

start :: IO ()
start = do
    let port = 8080
        settings =
            setPort port $
            setBeforeMainLoop (hPutStrLn stderr
                ("listening on port " `mappend` show port))
            defaultSettings
    runSettings settings =<< app

-- Note that  f <$> x  is the same thing as  do v <- x; return (f v)
-- do { s <- return 1 ; return (s + 1) ; } :: Maybe Int    =====    return 1 >>= \s -> return (s + 1) :: Maybe Int
-- app = simpleCors . serve api <$> getServer
app :: IO Application
app = do
    s <- getServer
    return $ logStdoutDev $ cors (const $ Just policy) $ serve (Proxy :: Proxy API) (serverWithSwagger s)
    where
      policy = simpleCorsResourcePolicy
        { corsRequestHeaders = ["Content-Type"] }

getServer :: IO (Server Api)
getServer = do
    db <- playerDB
    return $ server db

server :: DB -> Server Api
server db =
    getPlayers db :<|>
    getPlayerById db :<|>
    postPlayer db :<|>
    updatePlayerById db

getPlayers :: DB -> Handler [Player]
getPlayers db = liftIO $ getPmap db

getPlayerById :: DB -> PlayerId -> Handler Player
getPlayerById db id = maybe (throwE err404) return =<< liftIO (findPlayer db id)

postPlayer :: DB -> PlayerId -> Player -> Handler Player
postPlayer db id player = maybe (throwE err500) return =<< liftIO (insertPlayer db player >> findPlayer db id)

updatePlayerById :: DB -> PlayerId -> Player -> Handler Player
updatePlayerById db id player = maybe (throwE err500) return =<< liftIO (updatePlayer db id player >> findPlayer db id)
-- (\x -> maybe (throwE err500) (return) x) =<< liftIO (updatePlayer db id player >> findPlayer db id)

-- player map
data DB = DB (MVar PlayerMap)

type PlayerMap = M.Map PlayerId Player

existingPlayers :: [(PlayerId, Player)]
existingPlayers =
    [ (1, Player 1 "Sally" 2)
    , (2, Player 2 "Lance" 1)
    , (3, Player 3 "Aki" 3)
    , (4, Player 4 "Maria" 4)
    ]

getPmap :: DB -> IO [Player]
getPmap (DB mvar) = M.elems <$> readMVar mvar

playerDB :: IO DB
playerDB = DB <$> newMVar (M.fromList existingPlayers)

insertPlayer :: DB -> Player -> IO ()
insertPlayer (DB mvar) player = do
    pmap <- takeMVar mvar
    putMVar mvar (M.insert (playerId player) player pmap) -- insert player at { playerId: Player }

findPlayer :: DB -> PlayerId -> IO (Maybe Player)
findPlayer (DB mvar) idx = do
    pmap <- takeMVar mvar
    putMVar mvar pmap
    return (M.lookup idx pmap)

updatePlayer :: DB -> PlayerId -> Player -> IO ()
updatePlayer (DB mvar) id player = do
    pmap <- takeMVar mvar
    if M.member id pmap
        then putMVar mvar (M.insert id player pmap)
        else putMVar mvar pmap


-- attempt at a thread-safe logger
data Logger = Logger (MVar LogCommand)
data LogCommand = Log String | End (MVar ())

startLogger :: IO Logger
startLogger = do
    m <- newEmptyMVar
    let l = Logger m
    forkIO (logger l)
    return l

logger :: Logger -> IO ()
logger (Logger mvar) = do
    log <- takeMVar mvar
    case log of
        Log str -> do
            putStrLn str
            logger (Logger mvar)
        End m -> do
            putStrLn "Logger ending"
            putMVar m ()

logMessage :: Logger -> String -> IO ()
logMessage (Logger m) s = putMVar m (Log s)

logStop :: Logger -> IO ()
logStop (Logger m) = do
  s <- newEmptyMVar
  putMVar m (End s)
  takeMVar s

main :: IO ()
main = start

Relevant issue haskell-servant/servant-swagger#45 (comment).