Commit 9bc8529d authored by MrMan's avatar MrMan

Working patch by UUID

parent 121606d4
......@@ -4,12 +4,14 @@
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE FlexibleInstances #-}
module Server
(buildApp)
where
import Components.EntityStore.SQLite
import Control.Exception (Exception)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Reader (ask)
import Data.Aeson (ToJSON(..))
......@@ -19,21 +21,25 @@ import Data.Semigroup ((<>))
import Data.UUID (UUID)
import Database.SQLite.Simple (FromRow)
import Servant.API
import Servant.Server (ServerT, Application, serve, hoistServer)
import Servant (throwError)
import Servant.Server (ServerT, Application, ServantErr(..), serve, hoistServer, err500, err400)
import Types
import Util (rightOrServantErr, genericServerError)
import qualified Data.ByteString.Lazy.Char8 as DBL8
import qualified Data.Text as DT
type Name = DT.Text
type Greeting = DT.Text
type TodoAPI =
"todos" :> Get '[JSON] [WithUUID Task]
:<|> "todos" :> Capture "uuid" UUID :> Get '[JSON] (WithUUID Task)
:<|> "todos" :> Capture "uuid" UUID :> ReqBody '[JSON] (Partial TaskF) :> Patch '[JSON] (WithUUID Task)
todoServer :: ServerT TodoAPI AppHandler
todoServer = listTodos
:<|> getTodoByUUID
:<|> patchTodoByUUID
listTodos :: AppHandler [WithUUID Task]
listTodos = ask
......@@ -45,6 +51,14 @@ getTodoByUUID uuid = ask
>>= \(AppState _ estore) -> liftIO (getByUUID estore uuid :: IO (Either EntityStoreError (WithUUID Task)))
>>= rightOrServantErr genericServerError
patchTodoByUUID :: UUID -> Partial TaskF -> AppHandler (WithUUID Task)
patchTodoByUUID uuid partial = pure (validate partial)
>>= rightOrConvertToServantErr
>>= \validated -> ask
>>= \(AppState _ estore) -> liftIO (updateByUUID estore uuid validated :: IO (Either EntityStoreError (WithUUID (Complete TaskF))))
>>= rightOrConvertToServantErr
>>= pure . (toTaskFromF <$>)
todoAPI :: Proxy TodoAPI
todoAPI = Proxy
......@@ -52,3 +66,29 @@ buildApp :: AppState -> Application
buildApp state = serve todoAPI $ hoistServer todoAPI naturalTransform todoServer
where
naturalTransform = appToServantHandler state
-- | Ensure that an Either resolves to it's Right value
rightOrServantErr :: Exception a => ServantErr -> Either a b -> AppHandler b
rightOrServantErr err (Left _) = throwError err
rightOrServantErr _ (Right v) = return v
-- | Ensure that an Either resolves to it's Right value
rightOrConvertToServantErr :: (Exception err, ServableError err) => Either err b -> AppHandler b
rightOrConvertToServantErr (Left err) = throwError $ toServantError err
rightOrConvertToServantErr (Right v) = return v
genericServerError :: ServantErr
genericServerError = err500 { errBody = "Unexpected server error" }
makeValidationErr :: [ValidationError] -> ServantErr
makeValidationErr verrs = err400 { errBody = "Validation errors occurred:\n " <> DBL8.pack (show verrs) }
class ServableError err where
toServantError :: err -> ServantErr
instance ServableError EntityStoreError where
toServantError (UnexpectedErrorES txt) = err500 { errBody = DBL8.pack (DT.unpack txt) }
toServantError _ = err500 { errBody = "Unexpected error" }
instance ServableError [ValidationError] where
toServantError errs = makeValidationErr errs
......@@ -37,6 +37,7 @@ library:
- neat-interpolation
- transformers
- unordered-containers
- bytestring
executables:
haskell-restish-todo-exe:
......@@ -57,6 +58,7 @@ executables:
- transformers
- aeson
- sqlite-simple
- bytestring
- uuid
tests:
......
......@@ -77,9 +77,10 @@ instance forall a. ToRow a => ToRow (WithUUID a) where
toRow (WUUID id_ obj) = [toField id_] <> toRow obj
instance forall (state :: TaskState) a. ToRow (Complete (TaskFInState state)) where
toRow t@(FinishedT name desc) = toRow (name, desc, showState t)
toRow t@(InProgressT (Identity name) (Identity desc)) = toRow (name, desc, showState t)
toRow t@(NotStartedT (Identity name) (Identity desc)) = toRow (name, desc, showState t)
toRow = toRow . toTask
instance forall (state :: TaskState) a. ToRow (Complete TaskF) where
toRow = toRow . toTaskFromF
instance forall a. FromRow a => FromRow (WithUUID a) where
-- While normally FromRow instances are written like: `ValueConstructor <$> field <*> field ...`
......@@ -245,8 +246,12 @@ instance SQLInsertable Task where
columnNames = SQLCN ["name", "description", "state"]
instance forall (state :: TaskState). SQLInsertable (Complete (TaskFInState state)) where
tableName = TN "tasks"
columnNames = SQLCN ["name", "description", "state"]
tableName = let (TN tbl) = (tableName :: TableName Task) in TN tbl
columnNames = let (SQLCN cols) = (columnNames :: SQLColumnNames Task) in SQLCN cols
instance SQLInsertable (Complete TaskF) where
tableName = let (TN tbl) = (tableName :: TableName Task) in TN tbl
columnNames = let (SQLCN cols) = (columnNames :: SQLColumnNames Task) in SQLCN cols
instance ToRow Task where
toRow (Task n d s) = toRow (n, d, s)
......@@ -254,6 +259,9 @@ instance ToRow Task where
instance FromRow Task where
fromRow = Task <$> field <*> field <*> field
instance FromRow (Complete TaskF) where
fromRow = TaskF <$> field <*> field <*> field
-- | If some value e is SQLInsertable, then the same value with a UUID is insertable
-- All we do is ensure the columns include a "uuid" column at the beginning
instance forall e. SQLInsertable e => SQLInsertable (WithUUID e) where
......@@ -265,6 +273,12 @@ instance forall e. SQLInsertable e => SQLInsertable (WithUUID e) where
where
(SQLCN innerCols) = columnNames :: SQLColumnNames e
instance SQLUpdatable (Partial TaskF) where
updateColumnGetters _ = [ ("name", (toField <$>) . tfName)
, ("description", (toField <$>) . tfDesc)
, ("state", (toField <$>) . tfState)
]
instance SQLUpdatable (Partial (TaskFInState state)) where
updateColumnGetters NotStartedT{} = [ ("name", \(NotStartedT name _) -> toField <$> name)
, ("description", \(NotStartedT _ desc) -> toField <$> desc)
......@@ -343,20 +357,24 @@ updateEntityByUUID :: forall entity.
-> UUID
-> Partial entity
-> IO (Either EntityStoreError (WithUUID (Complete entity)))
updateEntityByUUID conn uuid partial = withTransaction conn updateAndCheckChanges
>>= \case
1 -> getEntityByUUID conn uuid
_ -> pure $ Left $ UnexpectedErrorES "Update failed, no rows were changed"
updateEntityByUUID conn uuid partial = case cols of
[] -> badPartialErr
_ -> withTransaction conn updateAndCheckChanges
>>= \case
1 -> getEntityByUUID conn uuid
_ -> noRowsChangedErr
where
(TN tbl) = tableName :: TableName (Complete entity)
(SQLCN cols) = updateColumns partial
setPhrase = DT.intercalate "," $ (<>"=?") <$> cols
badPartialErr = pure $ Left $ UnexpectedErrorES "Update contains no values"
noRowsChangedErr = pure $ Left $ UnexpectedErrorES "Update happened but no rows were changed"
values = updateValues partial
valuesWithID = values <> [toField uuid]
setPhrase = DT.intercalate "," $ (<>"=?") <$> cols
updateQuery = Query $ [text| UPDATE $tbl SET $setPhrase WHERE uuid = ? |]
updateQuery = Query $ [text| UPDATE $tbl SET $setPhrase WHERE uuid=? |]
updateAndCheckChanges = execute conn updateQuery valuesWithID
>> changes conn
......
......@@ -20,7 +20,7 @@ module Types where
import Data.HashMap.Lazy (insert)
import GHC.Generics (Generic)
import Data.Aeson (ToJSON(..), (.=), Value(..), object)
import Data.Aeson (FromJSON(..), ToJSON(..), (.=), Value(..), object)
import Control.Monad.Trans.Reader (ReaderT(..))
import Data.Bifunctor (second)
import Data.Kind(Type, Constraint)
......@@ -43,6 +43,7 @@ data TaskState = Finished
| NotStarted
| Some deriving (Eq, Enum, Read, Show, Generic)
instance ToJSON TaskState
-- Newtypes preventing careless
......@@ -50,6 +51,9 @@ type TaskName = DT.Text
type TaskDesc = DT.Text
type TaskStateValue = DT.Text
validTaskStateValues :: [TaskStateValue]
validTaskStateValues = ["Finished", "InProgress", "NotStarted"]
type Partial a = a Maybe
type Complete a = a Identity
......@@ -67,9 +71,17 @@ data TaskF f = TaskF { tfName :: f TaskName
deriving instance Eq (Complete TaskF)
deriving instance Show (Complete TaskF)
deriving instance Generic (Complete TaskF)
instance ToJSON (Complete TaskF)
instance FromJSON (Complete TaskF)
deriving instance Eq (Partial TaskF)
deriving instance Show (Partial TaskF)
deriving instance Generic (Partial TaskF)
instance ToJSON (Partial TaskF)
instance FromJSON (Partial TaskF)
-- The beefy task class
data TaskFInState (state :: TaskState) f where
......@@ -139,6 +151,9 @@ toTask (FinishedT (Identity name) (Identity desc)) = Task name desc "Finished"
toTask (UnknownStateT (Identity name) (Identity desc) (Identity state)) = Task name desc state
toTask (SomeStateT (Identity name) (Identity desc) (Identity state)) = Task name desc state
toTaskFromF :: Complete TaskF -> Task
toTaskFromF (TaskF (Identity name) (Identity desc) (Identity stateValue)) = Task name desc stateValue
taskNameField :: FieldName
taskNameField = "name"
......@@ -186,7 +201,10 @@ pTaskDesc (InProgressT _ desc) = DT.strip <$> desc
pTaskDesc (NotStartedT _ desc) = DT.strip <$> desc
nonEmptyIfPresent :: FieldName -> DT.Text -> Maybe ValidationError
nonEmptyIfPresent fieldname v = if DT.null v then Just (InvalidField taskNameField) else Nothing
nonEmptyIfPresent fieldname v = if DT.null v then Just (InvalidField fieldname) else Nothing
enumStrIfPresent :: [DT.Text] -> FieldName -> DT.Text -> Maybe ValidationError
enumStrIfPresent validValues fieldname v = if not (elem v validValues) then Just (InvalidField fieldname) else Nothing
instance Validatable (Partial (TaskFInState state)) where
validationChecks = [checkName, checkDescription]
......@@ -197,6 +215,18 @@ instance Validatable (Partial (TaskFInState state)) where
checkDescription :: Partial (TaskFInState state) -> Maybe ValidationError
checkDescription = maybe Nothing (nonEmptyIfPresent taskDescField) . pTaskDesc
instance Validatable (Partial TaskF) where
validationChecks = [nonEmptyName, nonEmptyDesc, validState]
where
nonEmptyName :: Partial TaskF -> Maybe ValidationError
nonEmptyName = maybe Nothing (nonEmptyIfPresent taskNameField) . tfName
nonEmptyDesc :: Partial TaskF -> Maybe ValidationError
nonEmptyDesc = maybe Nothing (nonEmptyIfPresent taskDescField) . tfDesc
validState :: Partial TaskF -> Maybe ValidationError
validState = maybe Nothing (enumStrIfPresent validTaskStateValues taskDescField) . tfState
----------------
-- Components --
----------------
......@@ -210,6 +240,9 @@ class Component c => Constructable c cfg err where
data WithUUID a = WUUID UUID a deriving (Eq, Show, Read)
instance Functor WithUUID where
fmap f (WUUID uuid a) = WUUID uuid (f a)
instance ToJSON a => ToJSON (WithUUID a) where
toJSON (WUUID uuid obj) = case toJSON obj of
obj@(Object map) -> Object $ insert "uuid" (String uuidTxt) map
......
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-}
module Util
( rightOrServantErr
, rightOrThrow
, genericServerError
)
( rightOrThrow )
where
import Servant.Server (ServantErr(..), err500)
import Control.Exception (Exception, throw)
import Control.Exception (Exception, throw)
-- | Ensure that an Either resolves to it's Right value
rightOrThrow :: (Exception a) => Either a b -> IO b
rightOrThrow e = case e of
(Left err) -> throw err
(Right v) -> return v
-- | Ensure that an Either resolves to it's Right value
rightOrServantErr :: (Exception a, Monad m) => ServantErr -> Either a b -> m b
rightOrServantErr err (Left _) = throw err
rightOrServantErr _ (Right v) = return v
genericServerError :: ServantErr
genericServerError = err500 { errBody = "Unexpected server error" }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment