SimpleAnimalAPI.hs

-- In memory REST API for getting Animal information.
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeOperators #-}

module SimpleAnimalAPI
  ( startApp,
    app,
  )
where

import Control.Concurrent.STM.TVar
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.STM (atomically)
import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask)
import Data.Aeson
import Data.Aeson qualified as JSON
import Data.List (find)
import Data.UUID
import GHC.Generics
import GHC.TypeLits
import Network.Wai
import Network.Wai.Handler.Warp
import Servant
import qualified Data.UUID as UUID

type ShitAPI (name :: Symbol) datum id =
  name
    :> ( Get '[JSON] [datum]
           :<|> Capture "id" id :> Get '[JSON] datum
           :<|> ReqBody '[JSON] Animal :> PostCreated '[JSON] Animal
       )

newtype AppState = AppState
  { _animals :: TVar [Animal]
  }

-- normally reader monads are meant for read-only state, but
-- in this case we wrap it in a TVar and use software
-- transactional memory to modify the variable within the
-- STM Monad

type AppM = ReaderT AppState Handler

data Kind = Dog | Cat | Horse | Chad
  deriving (Eq, Show, Generic)

instance FromJSON Kind

instance ToJSON Kind

data Animal = Animal
  { name :: String,
    age :: Int,
    kind :: Kind,
    animalId :: UUID
  }
  deriving (Eq, Show, Generic)

instance FromJSON Animal

instance ToJSON Animal

startApp :: IO ()
startApp = do
  animals <- newTVarIO []
  run 8080 (app animals)

app :: TVar [Animal] -> Application
app animals = do
  serve api $ hoistServer api (`runReaderT` AppState animals) animalServer

api :: Proxy (ShitAPI "animals" Animal UUID)
api = Proxy

animalServer :: ServerT (ShitAPI "animals" Animal UUID) AppM
animalServer = getAnimals :<|> getAnimalsById :<|> postAnimal
  where
    getAnimals :: AppM [Animal]
    getAnimals = do
      (AppState {_animals}) <- ask
      liftIO $ readTVarIO _animals

    getAnimalsById :: UUID -> AppM Animal
    getAnimalsById aid = do
      (AppState {_animals}) <- ask
      animals <- liftIO (readTVarIO _animals)
      case find (\(Animal {animalId}) -> animalId == aid) animals of
        Just animal -> pure animal
        Nothing -> throwError err404 {errBody = JSON.encode $ "Animal with ID '" <> UUID.toString aid <> "' not found."}

    postAnimal :: Animal -> AppM Animal
    postAnimal animal = do
      (AppState {_animals}) <- ask
      liftIO $ atomically $ readTVar _animals >>= writeTVar _animals . (animal :)
      return animal