{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Main where import Control.Applicative ((<|>)) import Control.Applicative.Combinators import Control.Monad.IO.Class import Control.Monad.Trans.Class import Data.Aeson (ToJSON, toJSON) import Data.ByteString.Lazy (fromStrict) import Data.Function ((&)) import Data.Maybe (listToMaybe) import Data.Text import Data.Text.Encoding (encodeUtf8) import Database.SQLite.Simple import Database.SQLite.Simple.FromField import Database.SQLite.Simple.ToField import GHC.Generics (Generic, Par1) import Okapi import Web.FormUrlEncoded (FromForm) import Web.HttpApiData (ToHttpApiData) import Web.Internal.HttpApiData {- We're going to build a Todo API with the following endpoints: GET / Health check. Returns 200 response with "OK" as the body. GET /todos Returns all todos as JSON. Has optional query param "status" to filter todos with that status. GET /todos/:uid Returns the todo with the matching :uid as JSON. POST /todos Accepts a todo/todos encoded as JSON to store on the server. PATCH /todos/:uid Accepts todo information as JSON. For updating a todo with the :uid. DELETE /todos/:uid Deletes the todo with the matching :uid from the server. -} -- TYPES -- data Todo = Todo { todoID :: Int, todoName :: Text, todoStatus :: Status } deriving (Eq, Ord, Generic, ToJSON, Show) instance FromRow Todo where fromRow = Todo <$> field <*> field <*> field data TodoForm = TodoForm { todoFormName :: Text, todoFormStatus :: Status } deriving (Eq, Ord, Generic, FromForm, Show) instance ToRow TodoForm where toRow (TodoForm name status) = toRow (name, status) data Status = Incomplete | Archived | Complete deriving (Eq, Ord, Show) instance ToJSON Status where toJSON Incomplete = "incomplete" toJSON Archived = "archived" toJSON Complete = "complete" instance FromHttpApiData Status where parseQueryParam "incomplete" = Right Incomplete parseQueryParam "archived" = Right Archived parseQueryParam "complete" = Right Complete parseQueryParam _ = Left "Incorrect format for Status value" instance ToField Status where toField status = case status of Incomplete -> SQLText "incomplete" Archived -> SQLText "archived" Complete -> SQLText "complete" instance FromField Status where fromField field = do case fieldData field of SQLText "incomplete" -> pure Incomplete SQLText "archived" -> pure Archived SQLText "complete" -> pure Complete _ -> returnError ConversionFailed field "Couldn't get Status value from field" type Okapi = OkapiT IO -- MAIN -- main :: IO () main = do conn <- open "todo.db" execute_ conn "CREATE TABLE IF NOT EXISTS todos (id INTEGER PRIMARY KEY, name TEXT, status TEXT)" run id notFound 3000 (todoAPI conn) close conn -- SERVER FUNCTIONS todoAPI :: Connection -> Okapi Response todoAPI conn = healthCheck <|> getTodo conn <|> getAllTodos conn <|> createTodo conn <|> editTodo conn <|> forgetTodo conn healthCheck :: Okapi Response healthCheck = do get optional $ pathSeg "" respond ok getTodo :: Connection -> Okapi Response getTodo conn = do get pathSeg "todos" todoID <- pathParam @Int maybeTodo <- lift $ selectTodo conn todoID case maybeTodo of Nothing -> throw $ Response 500 [] $ ResponseBodyRaw "" Just todo -> ok & json todo & respond getAllTodos :: Connection -> Okapi Response getAllTodos conn = do get pathSeg "todos" status <- optional $ queryParam @Status "status" todos <- lift $ selectAllTodos conn status ok & json todos & respond createTodo :: Connection -> Okapi Response createTodo conn = do post pathSeg "todos" todoForm <- bodyForm lift $ insertTodoForm conn todoForm respond ok editTodo :: Connection -> Okapi Response editTodo conn = do put pathSeg "todos" todoID <- pathParam @Int todoForm <- bodyForm @TodoForm lift $ updateTodo conn todoID todoForm respond ok forgetTodo :: Connection -> Okapi Response forgetTodo conn = do delete pathSeg "todos" todoID <- pathParam @Int lift $ deleteTodo conn todoID respond ok -- DATABASE FUNCTIONS insertTodoForm :: Connection -> TodoForm -> IO () insertTodoForm conn = execute conn "INSERT INTO todos (name, status) VALUES (?, ?)" selectTodo :: Connection -> Int -> IO (Maybe Todo) selectTodo conn todoID = listToMaybe <$> query conn "SELECT * FROM todos WHERE id = ?" (Only todoID) selectAllTodos :: Connection -> Maybe Status -> IO [Todo] selectAllTodos conn maybeStatus = case maybeStatus of Nothing -> query_ conn "SELECT * FROM todos" Just status -> query conn "SELECT * FROM todos WHERE status = ?" (Only status) updateTodo :: Connection -> Int -> TodoForm -> IO () updateTodo conn todoID TodoForm {..} = executeNamed conn "UPDATE todos SET name = :name, status = :status WHERE id = :id" [":id" := todoID, ":name" := todoFormName, ":status" := todoFormStatus] deleteTodo :: Connection -> Int -> IO () deleteTodo conn todoID = execute conn "DELETE FROM todos WHERE id = ?" (Only todoID)