Stuff

src/PEA/Server/API.hs

@@ -18,6 +18,7 @@ import Network.Wai.Handler.Warp
 import Servant
 
 import PEA.Server.Types
+import PEA.Server.SQL
 
 
 type CRUD (name :: Symbol) a = name :>
@@ -38,11 +39,7 @@ tags user = readAllTags user
     :<|> (\i -> readOneTag i user :<|> updateTag i user :<|> deleteTag i user)
 
 
-createTag
-
-readAllTags
-
-type Tasks = CRUD "tasks" Task
+type Tasks = CRUD "tasks" Task'
 
 tasks :: User -> Server Tasks
 tasks user = readAllTasks

src/PEA/Server/SQL.hs

@@ -1,7 +1,128 @@
-module PEA.Server.SQL where
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
 
+module PEA.Server.SQL where
+    
 import Database.Persist
 import Database.Persist.Sqlite
 import Database.Persist.TH
+import Servant
+
+import PEA.Server.Types
+
+-- Assistance from https://github.com/cdepillabout/testing-code-that-accesses-db-in-haskell/blob/master/without-db/datatype/src/Lib.hs
+data DBAccess m = DBAccess
+                    { runDb :: m a -> EitherT ServantErr IO a
+                    -- Tags
+                    , getTag :: Key Tag -> m (Maybe Tag)
+                    , allTags :: [Tag]
+                    , insertTag ::  Tag -> m (Key Tag)
+                    , deleteTag :: Key Tag -> m ()
+                    , updateTag :: Key Tag -> Tag -> m ()
+                    -- Tasks
+                    , getTask :: Key Task' -> m (Maybe Task')
+                    , allTags :: [Task']
+                    , insertTask :: Task' -> m (Key Task')
+                    , deleteTask :: Key Task' -> m ()
+                    , updateTask :: Key Task' -> Task' -> m ()
+                    -- Users
+                    , getUser :: Key User -> m (Maybe User')
+                    , allUsers :: [User]
+                    , insertUser :: User -> m (Key User')
+                    , deleteUser :: Key User -> m ()
+                    , updateUser :: Key User -> User -> m ()
+                    }
+
+getTagOr404 :: MonadThrow m => DBAccess m -> Key Tag -> m Tag
+getTagOr404 db key = do
+    maybeVal <- getTag db key
+    case maybeVal of
+        Just tag -> return tag
+        Nothing -> throwM err404
+
+getTaskOr404 :: MonadThrow m => DBAccess m -> Key Task' -> m Task'
+getTaskOr404 db key = do
+    maybeVal <- getTask db key
+    case maybeVal of
+        Just task -> return task
+        Nothing -> throwM err404
+
+getUserOr404 :: MonadThrow m => DBAccess m -> Key User -> m User
+getUserOr404 db key = do
+    maybeVal <- getUser db key
+    case maybeVal of
+        Just user -> return user
+        Nothing -> throwM err404
+
+prodDB :: SqlBackend -> User -> DBAccess (SqlPersistT IO)
+prodDB config user = DBAccess
+                       { runDb = runDb' config
+                       , getTag = getTag'
+                       , allTags = allTags'
+                       , insertTag = insertTag'
+                       , deleteTag = deleteTag'
+                       , updateTag = updateTag'
+                       , getTask = getTask'
+                       , allTasks = allTasks'
+                       , insertTask = insertTask'
+                       , deleteTask = deleteTask'
+                       , updateTask = updateTask'
+                       , getUser = getUser'
+                       , allUsers = allUsers'
+                       , insertUser = insertUser'
+                       , deleteUser = deleteUser'
+                       , updateUser = updateUser'
+                       }
+  where
+      runDb' :: SqlBackend -> SqlPersistT IO a -> EitherT ServantErr IO a
+      runDb' conn query =
+          liftIO (runSqlConn query conn)
+              `catch` \(err :: ServantErr) -> throwErr err
+
+      currentUserId :: Key User
+      currentUserId = userId user
+
+      getTag' :: Key Tag -> SqlPersistT IO (Maybe Tag)
+      getTag' = get
+
+      allTags' :: SqlPersistT IO [Tag]
+      allTags' = selectList [TagOwnerId ==. currentUserId] []
+
+      insertTag' :: Tag -> SqlPersistT IO (Key Tag)
+      insertTag' = insert
+
+      deleteTag' :: Key Tag -> SqlPersistT IO ()
+      deleteTag' = delete
+
+      updateTag' :: Key Tag -> Tag -> SqlPersistT IO ()
+      updateTag' = replace
+
+      getTask' :: Key Task' -> SqlPersistT IO (Maybe Task')
+      getTask' = get
+
+      allTasks' :: SqlPersistT IO [Task']
+      allTasks = selectList [TaskOwnerId ==. currentUserId] []
+
+      insertTask' :: Task -> SqlPersistT IO (Key Task')
+      insertTask' = insert
+
+      deleteTask' :: Key Task' -> SqlPersistT IO ()
+      deleteTask' = delete
+
+      updateTask' :: Key Task' -> Task' -> SqlPersistT IO ()
+      updateTask' = replace
+
+      getUser' :: Key User -> SqlPersistT IO (Maybe User)
+      getTask' = get
+
+      allUsers' :: SqlPersistT IO [User]
+      allUsers' = selectList [UserId !=. currentUserId] []
+
+      insertUser' :: User -> SqlPersistT IO (Key User)
+      insertUser' = insert
 
+      deleteUser' :: Key User -> SqlPersistT IO ()
+      deleteUser' = delete
 
+      updateUser' :: Key User -> User -> SqlPersistT IO ()
+      updateUser' = replace

src/PEA/Server/Types.hs

@@ -68,15 +68,15 @@ TaskEdges
 type Efforts = Map.Map Int String
 type Priorities = Map.Map Int String
 
-data TaskNode = TaskNode
+data Task' = Task'
   { props :: Task
   , tagIds :: [TagId]
   , parents :: [TaskId]
   , children :: [TaskId]
   } deriving (Eq, Show, Generic)
 
-instance ToJSON TaskNode
-instance FromJson TaskNode
+instance ToJSON Task'
+instance FromJson Task'
 
 data UserData = UserData
   { user :: User