Refactoring API again

PEA.cabal

@@ -40,15 +40,15 @@ library
         , PEA.Client.Elm
         , PEA.Server
         , PEA.Server.API
-        , PEA.Server.Data
-        , PEA.Server.Data.Graph
-        , PEA.Server.Data.SQL
-        , PEA.Types
+        , PEA.Server.SQL
+        , PEA.Server.Types
     build-depends:
         aeson
+        , algebraic-graphs
         , containers
-        , opaleye
-        , product-profunctors
+        , persistent
+        , persistent-postgresql
+        , persistent-template
         , servant-server
         , time
         , uuid
@@ -57,14 +57,21 @@ library
 
 executable pea-srv
     import: shared-properties
-    main-is:          Service.hs
+    main-is: Service.hs
 
     -- Modules included in this executable, other than Main.
     -- other-modules:
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
-    hs-source-dirs:   app
+    hs-source-dirs: app
+    build-depends:
+        PEA
+
+executable pea-migrate
+    import: shared-properties
+    main-is: Migrate.hs
+    hs-source-dirs: app
     build-depends:
         PEA
 

app/Migrate.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import PEA.Server.Types
+
+main :: IO ()
+main = runSqlite ":memory:" $ do runMigration migrateAll

src/PEA/Client.hs

@@ -1 +0,0 @@
-module PEA.Client where

src/PEA/Server.hs

@@ -1,17 +0,0 @@
-module PEA.Server where
-
-import Network.Wai
-import Network.Wai.Handler.Warp
-import Servant
-
-import PEA.Server.API
-
-
-api :: Proxy All
-api = Proxy
-
-app :: Application
-app = serve api server
-
-main :: IO ()
-main = run 8081 app

src/PEA/Server/API.hs

@@ -9,178 +9,119 @@
 module PEA.Server.API where
 
 import Data.Aeson
-import qualified Data.Map.Strict as Map
-import Data.Time.LocalTime
-import Data.UUID
+import Data.Time.Clock
+import Database.Persist
 import GHC.Generics
 import GHC.TypeLits
+import Network.Wai
+import Network.Wai.Handler.Warp
 import Servant
 
-import PEA.Server.Data
+import PEA.Server.Types
 
 
-server :: CookieSettings -> JWTSettings -> Server (API auths)
-server cs jwts = protected :<|> unprotected cs jwts
+type CRUD (name :: Symbol) a = name :>
+  (                                                   Get '[JSON] (Normal a)
+  :<|>                           ReqBody '[JSON] a :> Post '[JSON] (Key a)
+  :<|> Capture "id" (Key a) :>
+                            (                         Get '[JSON] a
+                            :<|> ReqBody '[JSON] a :> Put '[JSON] ()
+                            :<|>                      Delete '[JSON] ()
+                            )
+  )
 
-type API auths = (Auth auths User :> Protected) :<|> Unprotected
+type Tags = CRUD "tags" String
 
-protected :: AuthResult User -> Server Protected
-protected (Authenticated user) = return adminServer user :<|> return myServer user
-protected _ = throwAll err401
+tags :: User -> Server Tags
+tags user = readAllTags user
+    :<|> createTag user
+    :<|> (\i -> readOneTag i user :<|> updateTag i user :<|> deleteTag i user)
 
-type Protected = Admin :<|> My
 
-data User = User
-  { name :: String
-  , email :: String
-  } deriving (Eq, Show, Read, Generic)
+createTag
 
-instance ToJSON User
-instance ToJWT User
-instance FromJSON User
-instance FromJWT User
+readAllTags
 
-unprotected :: CookieSettings -> JWTSettings -> Server Unprotected
-unprotected cs jwts = checkCreds cs jwts
+type Tasks = CRUD "tasks" Task
 
-type Unprotected =
-     "login"
-          :> ReqBody '[JSON] Login
-          :> Verb 'POST 204 '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
-                                              , Header "Set-Cookie" SetCookie]
-                                              NoContent)
+tasks :: User -> Server Tasks
+tasks user = readAllTasks
+    :<|> createTask user
+    :<|> (\i -> readOneTask i user :<|> updateTask i user :<|> deleteTask i user)
 
-data Login = Login
+
+users :: User -> Server Users
+users user = readAllUsers
+    :<|> createUser user
+    :<|> (\i -> readOneUser i user :<|> updateUser i user :<|> deleteUser i user)
+
+type Users = CRUD "users" UserData
+
+data Credentials = Credentials
   { username :: String
   , password :: String
   } deriving (Eq, Show, Read, Generic)
 
-instance ToJSON Login
-instance ToJWT Login
-instance FromJSON Login
-instance FromJWT Login
+instance ToJSON Credentials
+instance ToJWT Credentials
+instance FromJSON Credentials
+instance FromJWT Credentials
 
-adminServer :: User -> Server Admin
-adminServer user = return $ tagServer user :<|> return $ taskServer user :<|> return $ userServer user
+
+type Data = "data" :> Get '[JSON] UserData
 
 type Admin = "admin" :> (Tags :<|> Tasks :<|> Users)
 
-myServer :: User -> Server My
-my user = return $ dataServer user :<|> return $ tagServer user :<|> return $ taskServer user
+admin :: Server Admin
+admin = return tags :<|> return tasks :<|> return users
 
 type My = "my" :> (Data :<|> Tags :<|> Tasks)
 
+my :: Server My
+my = return dataServer :<|> return tags :<|> return tasks
+
 dataServer :: User -> Server UserData
 dataServer user = return $ userData user
   where
       userData :: User -> Handler UserData
       userData user = return fetchUserData user
 
-type Data = "data" :> Get '[JSON] UserData
+type Protected = Admin :<|> My
 
-data UserData = UserData
-  { user :: User
-  , preferences :: UserPreferences
-  , properties :: UserProperties
-  , tags :: Normal Tag
-  , tasks :: Normal Task
-  } deriving (Eq, Show, Generic)
-
-instance ToJSON UserData
-instance FromJSON UserData
-
-data UserPreferences = UserPreferences
-  { effortM :: Map.Map Int String
-  , priorityM :: Map.Map Int String
-  , theme :: String
-  } deriving (Eq, Show, Generic)
-
-instance ToJSON UserPreferences
-instance FromJSON UserPreferences
-
-data UserProperties = UserProperties
-  { active :: Bool
-  , registration :: UTCTime
-  , superuser :: Bool
-  } deriving (Eq, Show, Generic)
-
-instance ToJSON UserProperties
-instance FromJSON UserProperties
-
-data Normal a = Normal
-  { ids :: [UUID]
-  , entities :: Map.Map UUID a
-  } deriving (Eq, Show, Generic)
-
-instance ToJSON Normal
-instance FromJSON Normal
-
-normalize :: [(UUID, a)] -> Normal a
-normalize pairs = foldl normalize' empty' pairs
-  where
-      empty' = Normal [] Map.empty
-      normalize' acc (uuid, ent) =
-          let
-            prevIds = ids acc
-            prevEnts = entities acc
-          in Normal
-            { ids = uuid : prevIds
-            , entities = Map.insert uuid ent prevEnts
-            }
-
-tagServer :: User -> Server Tags
-tagServer user = readAllTags user
-    :<|> createTag user
-    :<|> (\uuid -> readOneTag uuid user :<|> updateTag uuid user :<|> deleteTag uuid user)
+protected :: AuthResult Credentials -> Server Protected
+protected (Authenticated creds) = return admin :<|> return my
+protected _ = throwAll err401
 
-type Tags = CRUD "tags" Tag
+data Login = Login
+  { username :: String
+  , password :: String
+  } deriving (Eq, Show, Read, Generic)
 
-type Tag = String
+instance ToJSON Login
+instance ToJWT Login
+instance FromJSON Login
+instance FromJWT Login
 
-type CRUD (name :: Symbol) a = name :>
-  (                                                  Get '[JSON] (Normal a)
-  :<|>                          ReqBody '[JSON] a :> PostNoContent
-  :<|> Capture "uuid" UUID :>
-                           (                         Get '[JSON] a
-                           :<|> ReqBody '[JSON] a :> PutNoContent
-                           :<|>                      DeleteNoContent
-                           )
-  )
+unprotected :: CookieSettings -> JWTSettings -> Server Unprotected
+unprotected cs jwts = checkCreds cs jwts
+
+type Unprotected =
+     "login"
+          :> ReqBody '[JSON] Login
+          :> Verb 'POST 204 '[JSON] (Headers '[ Header "Set-Cookie" SetCookie
+                                              , Header "Set-Cookie" SetCookie]
+                                              NoContent)
 
-taskServer :: Server Tasks
-taskServer = readAllTasks
-    :<|> createTask
-    :<|> (\uuid -> readOneTask uuid :<|> updateTask uuid :<|> deleteTask uuid)
+type API auths = (Auth auths Credentials :> Protected) :<|> Unprotected
 
-type Tasks = CRUD "tasks" Task
+server :: CookieSettings -> JWTSettings -> Server (API auths)
+server cs jwts = protected :<|> unprotected cs jwts
 
-data Task = Task
-  { parents :: [UUID]
-  , children :: [UUID]
-  , taskProperties :: TaskProperties
-  , tagsIds :: [UUID]
-  } deriving (Eq, Show, Generic)
-
-instance ToJSON Task
-instance FromJSON Task
-
-data TaskProperties = TaskProperties
-  { created :: UTCTime
-  , description :: String
-  , due :: UTCTime
-  , duration :: Int
-  , effort :: Int
-  , priority :: Int
-  , progress :: Rational
-  , title :: String
-  } deriving (Eq, Show, Generic)
-
-instance ToJSON TaskProperties
-instance FromJSON TaskProperties
-
-userServer :: Server Users
-userServer = readAllUsers
-    :<|> createUser
-    :<|> (\uuid -> readOneUser uuid :<|> updateUser uuid :<|> deleteUser uuid)
+api :: Proxy All
+api = Proxy
 
-type Users = CRUD "users" UserData
+app :: Application
+app = serve api server
+
+main :: IO ()
+main = run 8081 app

src/PEA/Server/Data.hs

@@ -5,53 +5,53 @@ module PEA.Server.Data where
 import Data.UUID
 import Servant
 
-import PEA.Server.API
-import PEA.Server.SQL
+import qualified PEA.Server.API as API
+import qualified PEA.Server.SQL as SQL
 
 
-readAllTags :: User -> Handler [Tag]
+readAllTags :: API.User -> Handler [API.Tag]
 readAllTags user = return tags
   where
       dbUser = userByNameAndEmail (name user, email user)
       tags = tagsByUser dbUser
 
-createTag :: Tag -> Handler NoContent
+createTag :: API.Tag -> Handler NoContent
 createTag tag = return NoContent
 
-readOneTag :: UUID -> Handler Tag
+readOneTag :: UUID -> Handler API.Tag
 readOneTag uuid = return $ head $ [t | t <- tags, tagId t == uuid]
 
-updateTag :: UUID -> Tag -> Handler NoContent
+updateTag :: UUID -> API.Tag -> Handler NoContent
 updateTag _ _ = return NoContent
 
 deleteTag :: UUID -> Handler NoContent
 deleteTag _ = return NoContent
 
-readAllTasks :: Handler [Task]
+readAllTasks :: Handler [API.Task]
 readAllTasks = return tasks
 
-createTask :: Task -> Handler NoContent
+createTask :: API.Task -> Handler NoContent
 createTask _ = return NoContent
 
-readOneTask :: UUID -> Handler Task
+readOneTask :: UUID -> Handler API.Task
 readOneTask uuid = return $ head $ [t | t <- tasks, taskId t == uuid]
 
-updateTask :: UUID -> Task -> Handler NoContent
+updateTask :: UUID -> API.Task -> Handler NoContent
 updateTask _ _ = return NoContent
 
 deleteTask :: UUID -> Handler NoContent
 deleteTask _ = return NoContent
 
-readAllUsers :: Handler [User]
+readAllUsers :: Handler [API.User]
 readAllUsers = return users
 
 createUser :: User -> Handler NoContent
 createUser _ = return NoContent
 
-readOneUser :: UUID -> Handler User
+readOneUser :: UUID -> Handler API.User
 readOneUser uuid = return $ head $ [u | u <- users, uId u == uuid]
 
-updateUser :: UUID -> User -> Handler NoContent
+updateUser :: UUID -> API.User -> Handler NoContent
 updateUser _ _ = return NoContent
 
 deleteUser :: UUID -> Handler NoContent

src/PEA/Server/Graph.hs

@@ -1 +0,0 @@
-module PEA.Server.Graph where

src/PEA/Server/SQL.hs

@@ -1,148 +1,7 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TemplateHaskell #-}
-
 module PEA.Server.SQL where
 
-import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
-import Data.Time.LocalTime
-import qualified Opaleye as O
-import Opaleye ((.==))
-import Data.UUID
-
-{-
-type DbEntity = DbTag | DbTask | DbUser
-
-data DbAccess m =
-    DbAccess { runDb :: forall a . m a -> EitherT ServantErr IO a
-             , createDb :: DbEntity -> m UUID
-             , readDb :: UUID -> m (Maybe DbEntity)
-             , updateDb :: UUID -> DbEntity -> m ()
-             , deleteDb :: UUID -> m ()
-             }
--}
-
-type UuidField = O.Field O.SqlUuid
-type TextField = O.Field O.SqlText
-type TimestampField = O.Field O.SqlTimestamp
-
-data DbTag' a b = DbTag
-  { tagId :: a
-  , tagOwner :: a
-  , txt :: b
-  }
-
-type DbTag = DbTag' UUID String
-type DbTagField = DbTag' UuidField TextField
-
-$(makeAdaptorAndInstance "pDbTag" ''DbTag')
-
-tagTable :: O.Table DbTagField DbTagField
-tagTable = O.table "tags"
-                   (pDbTag DbTag { tagId = O.tableField "id"
-                                 , tagOwner = O.tableField "owner_id"
-                                 , txt = O.tableField "text"
-                                 })
-
-tagSelect :: O.Select DbTagField
-tagSelect = O.selectTable tagTable
-
-
-data DbTask' a b c d = DbTask
-  { taskId :: a
-  , taskOwner :: a
-  , title :: b
-  , description :: b
-  , duration :: c
-  , priority :: c
-  , effort :: c
-  , created :: d
-  , due :: d
-  }
-
-type DbTask = DbTask' UUID String Int LocalTime
-type DbTaskField = DbTask' UuidField TextField (O.Field O.SqlInt4) TimestampField
-
-$(makeAdaptorAndInstance "pDbTask" ''DbTask')
-
-taskTable :: O.Table DbTaskField DbTaskField
-taskTable = O.table "tasks"
-                    (pDbTask DbTask { taskId = O.tableField "id"
-                                    , taskOwner = O.tableField "owner_id"
-                                    , title = O.tableField "title"
-                                    , description = O.tableField "description"
-                                    , duration = O.tableField "duration"
-                                    , priority = O.tableField "priority"
-                                    , effort = O.tableField "effort"
-                                    , created = O.tableField "created"
-                                    , due = O.tableField "due"
-                                    })
-
-taskSelect :: O.Select DbTaskField
-taskSelect = O.selectTable taskTable
-
-data DbUser' a b c = DbUser
-  { name :: a
-  , email :: a
-  , active :: b
-  , superuser :: b
-  , registration :: c
-  , passcode :: a
-  }
-
-type DbUser = DbUser' String Bool LocalTime
-type DbUserField = DbUser' TextField (O.Field O.SqlBool) TimestampField
-
-$(makeAdaptorAndInstance "pDbUser" ''DbUser')
-
-userTable :: O.Table DbUserField DbUserField
-userTable = O.table "users"
-                    (pDbUser DbUser { name = O.tableField "name"
-                                    , email = O.tableField "email"
-                                    , active = O.tableField "active"
-                                    , superuser = O.tableField "superuser"
-                                    , registration = O.tableField "registration"
-                                    , passcode = O.tableField "passcode"
-                                    })
-
-userSelect :: O.Select DbUserField
-userSelect = O.selectTable userTable
-
-userByNameAndEmail :: (String, String) -> O.Select DbUserField
-userByNameAndEmail (name', email') = do
-    user <- userSelect
-    O.where_ $ name user .== name' .&& email user .== email'
-    pure user
-
-deleteTag :: DbTagField -> O.Delete DbTagField
-deleteTag = O.Delete
-    { dTable = tagTable
-    , dWhere = \(id, owner, txt) -> id .==
-    , dReturning = rCount
-    }
-
-insertTag :: DbTagField -> O.Insert DbTagField
-insertTag tag = O.Insert
-    { iTable         = tagTable
-    , iRow           = [tag]
-    , iReturning     = rCount
-    , iOnConflict    = Nothing
-    }
-
-tagsByUser :: DbUserField -> O.Select DbTagField
-tagByUser user = do
-    tag  <- tagSelect
-    O.where_ $ tagOwner tag .== userId user
-    pure tag
+import Database.Persist
+import Database.Persist.Sqlite
+import Database.Persist.TH
 
-tagByUUID :: UuidField -> O.Select DbTagField
-tagByUUID uuid = do
-    tag <- tagSelect
-    O.where_ $ tagId tag .== uuid
-    pure tag
 
-tasksByUser :: DbUserField -> O.Select DbTaskField
-taskByUser user = do
-    task <- taskSelect
-    O.where_ $ taskOwner task .== userId user
-    pure task

src/PEA/Server/Types.hs

@@ -0,0 +1,107 @@
+{-# LANGUAGE EmptyDataDecls             #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeFamilies               #-}
+
+module PEA.Server.Types where
+
+import Data.Aeson
+import qualified Data.Map.Strict as Map
+import Data.Time.Clock
+import Data.UUID
+import Database.Persist
+import Database.Persist.Sqlite
+import Database.Persist.TH
+
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+User
+  name String
+  email String
+  active Bool
+  passcode String
+  registration UTCTime
+  superuser Bool
+  theme String
+  deriving Show
+Effort
+  ownerId UserId
+  level Int
+  label Int
+  deriving Show
+Priority
+  ownerId UserId
+  level Int
+  label Int
+  deriving Show
+Tag
+  ownerId UserId
+  txt String
+  deriving Show
+Task
+  ownerId UserId
+  title String
+  description String
+  duration Int
+  effort Int
+  priority Int
+  progress Rational
+  created UTCTime
+  due UTCTime
+  deriving Show
+TaskTags
+  taskId TaskId
+  tagId TagId
+  TaskTag taskId tagId
+  deriving Show
+TaskEdges
+  parent TaskId
+  child TaskId
+  TaskEdge parent child
+  deriving Show
+|]
+
+type Efforts = Map.Map Int String
+type Priorities = Map.Map Int String
+
+data TaskNode = TaskNode
+  { props :: Task
+  , tagIds :: [TagId]
+  , parents :: [TaskId]
+  , children :: [TaskId]
+  } deriving (Eq, Show, Generic)
+
+instance ToJSON TaskNode
+instance FromJson TaskNode
+
+data UserData = UserData
+  { user :: User
+  , efforts :: Efforts
+  , priorities :: Priorities
+  , tags :: Normal String
+  , tasks :: Normal TaskNode
+  } deriving (Eq, Show, Generic)
+
+instance ToJSON UserData
+instance FromJSON UserData
+
+data Normal a = Normal
+  { keys :: [(Key a)]
+  , entities :: Map.Map (Key a) a
+  } deriving (Eq, Show, Generic)
+
+instance ToJSON Normal
+instance FromJSON Normal
+
+normalize :: [((Key a), a)] -> Normal a
+normalize pairs = foldl normalize' empty' pairs
+  where
+      empty' = Normal [] Map.empty
+      normalize' acc (key, ent) = Normal
+                                { keys = key : keys acc
+                                , entities = Map.insert key ent (entities acc)
+                                }