Add tests and fix type errors

PEA.cabal

@@ -48,6 +48,7 @@ library
         aeson
         , containers
         , opaleye
+        , product-profunctors
         , servant-server
         , time
         , uuid
@@ -66,3 +67,17 @@ executable pea-srv
     hs-source-dirs:   app
     build-depends:
         PEA
+
+test-suite test
+    type: exitcode-stdio-1.0
+    import: shared-properties
+    main-is: Driver.hs
+    hs-source-dirs:   test
+    build-depends:
+        PEA
+        , hedgehog
+        , tasty
+        , tasty-discover
+        , tasty-hedgehog
+    build-tool-depends:
+        tasty-discover:tasty-discover

src/PEA/Server/API.hs

@@ -25,14 +25,13 @@ type CRUD (name :: Symbol) a = name :>
                         )
   )
 
-type All = Tasks :<|> Users
+type All = Tags :<|> Tasks :<|> Users
+
+type Tags = CRUD "tags" Tag'
+type Tag' = Tag Int String
 
 type Tasks = CRUD "tasks" Task'
-type Task' = Task String Int Day
-instance FromJSON Task'
-instance ToJSON Task'
+type Task' = Task Int Day String
 
 type Users = CRUD "users" User'
-type User' = User String Bool Day
-instance FromJSON User'
-instance ToJSON User'
+type User' = User Int Bool String String Day Bool

src/PEA/Server/Data.hs

@@ -7,17 +7,17 @@ import Servant
 
 import PEA.Types
 
-type Task' = Task String Int Day
-type User' = User String Bool Day
+type Task' = Task Int Day String
+type User' = User Int Bool String String Day Bool
 
 tasks :: [Task']
 tasks =
-    [ emptyTask "first" "test"
-    , emptyTask "second" "test"
+    [ emptyTask
+    , emptyTask
     ]
 
 users :: [User']
-users = [ emptyUser "test" ]
+users = [ emptyUser ]
 
 readAllTasks :: Handler [Task']
 readAllTasks = return tasks

src/PEA/Server/Data/SQL.hs

@@ -1,12 +1,14 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module PEA.Server.Data.SQL where
 
+import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
 import Data.Time.Calendar
 import Data.Time.LocalTime
 import qualified Opaleye as O
-import Opaleye (.==)
-import Servant
+import Opaleye ((.==))
 import Data.UUID
 
 {-
@@ -25,7 +27,7 @@ type UuidField = O.Field O.SqlUuid
 type TextField = O.Field O.SqlText
 type TimestampField = O.Field O.SqlTimestamp
 
-data DbTag' a b = DbTag'
+data DbTag' a b = DbTag
   { tagId :: a
   , tagOwner :: a
   , txt :: b
@@ -43,11 +45,11 @@ tagTable = O.table "tags"
                                  , txt = O.tableField "text"
                                  })
 
-tagSelect :: O.Select DbTag
+tagSelect :: O.Select DbTagField
 tagSelect = O.selectTable tagTable
 
 
-data DbTask' a b c d e = DbTask'
+data DbTask' a b c d e = DbTask
   { taskId :: a
   , taskOwner :: a
   , title :: b
@@ -77,10 +79,10 @@ taskTable = O.table "tasks"
                                     , due = O.tableField "due"
                                     })
 
-taskSelect :: O.Select DbTask
+taskSelect :: O.Select DbTaskField
 taskSelect = O.selectTable taskTable
 
-data DbUser' a b c d = DbUser'
+data DbUser' a b c d = DbUser
   { userId :: a
   , name :: b
   , active :: c
@@ -89,8 +91,8 @@ data DbUser' a b c d = DbUser'
   , passcode :: b
   }
 
-data DbUser = DbUser' UUID String Bool LocalTime
-data DbUserField = DbUser' UuidField TextField (O.Field O.SqlBool) TimestampField
+type DbUser = DbUser' UUID String Bool LocalTime
+type DbUserField = DbUser' UuidField TextField (O.Field O.SqlBool) TimestampField
 
 $(makeAdaptorAndInstance "pDbUser" ''DbUser')
 
@@ -104,16 +106,16 @@ userTable = O.table "users"
                                     , passcode = O.tableField "passcode"
                                     })
 
-userSelect :: O.Select DbUser
-userSelect = selectTable userTable
+userSelect :: O.Select DbUserField
+userSelect = O.selectTable userTable
 
-tagByUser :: DbUser -> O.Select DbTag
+tagByUser :: DbUserField -> O.Select DbTagField
 tagByUser user = do
     tag  <- tagSelect
     O.where_ $ tagOwner tag .== userId user
     pure tag
 
-taskByUser :: DbUser -> O.Select DbTask
+taskByUser :: DbUserField -> O.Select DbTaskField
 taskByUser user = do
     task <- taskSelect
     O.where_ $ taskOwner task .== userId user

src/PEA/Types.hs

@@ -2,6 +2,7 @@
 
 module PEA.Types where
 
+import Data.Aeson
 import qualified Data.Map.Strict as Map
 import Data.Time.Calendar
 import GHC.Generics
@@ -17,6 +18,9 @@ tag i t = Tag i t
 emptyTag :: Tag Int String
 emptyTag = tag 0 ""
 
+instance ToJSON Tag
+instance FromJSON Tag
+
 data Task a b c = Task
   { taskId :: a
   , properties :: TaskProperties a
@@ -26,33 +30,42 @@ data Task a b c = Task
   } deriving (Eq, Show, Generic)
 
 task :: Num a => a -> TaskProperties a -> TaskDates b -> [(Tag a c)] -> TaskText c -> Task a b c
-task i properties dates text tags = Task i properties dates text tags
+task i props ds t ts = Task i props ds t ts
 
 emptyTask :: Task Int Day String
 emptyTask = task 0 emptyTaskProperties emptyTaskDates [emptyTag] emptyTaskText
 
+instance ToJSON Task
+instance FromJSON Task
+
 data TaskDates a = TaskDates
   { created :: a
   , due :: a
-  }
+  } deriving (Eq, Show, Generic)
 
 taskDates :: a -> a -> TaskDates a
-taskDates created due = TaskDates created due
+taskDates create du = TaskDates create du
 
 emptyTaskDates :: TaskDates Day
 emptyTaskDates = let day = ModifiedJulianDay 0 in taskDates day day
 
+instance ToJSON TaskDates
+instance FromJSON TaskDates
+
 data TaskProperties a = TaskProperties
   { duration :: a
   , effort :: a
   , priority :: a
-  }
+  } deriving (Eq, Show, Generic)
 
 taskProperties :: Num a => a -> a -> a -> TaskProperties a
 taskProperties dur eff pri = TaskProperties dur eff pri
 
 emptyTaskProperties :: TaskProperties Int
-emptyTaskProperties = TaskProperties
+emptyTaskProperties = taskProperties 0 0 0
+
+instance ToJSON TaskProperties
+instance FromJSON TaskProperties
 
 data TaskText a = TaskText
   { description :: a
@@ -60,11 +73,14 @@ data TaskText a = TaskText
   } deriving (Eq, Show, Generic)
 
 taskText :: a -> a -> TaskText a
-taskText desc title = TaxtText desc title
+taskText desc titl = TaskText desc titl
 
 emptyTaskText :: TaskText String
 emptyTaskText = taskText "" ""
 
+instance ToJSON TaskText
+instance FromJSON TaskText
+
 data User a b c d e f = User
   { uId :: a
   , active :: b
@@ -75,25 +91,28 @@ data User a b c d e f = User
   } deriving (Eq, Show, Generic)
 
 user :: Num a => a -> b -> c -> d -> e -> f -> User a b c d e f
-user i act name pass reg super = User i act name pass reg super
+user i act nam pass reg super = User i act nam pass reg super
 
 emptyUser :: User Int Bool String String Day Bool
 emptyUser = user 0 True "" "" (ModifiedJulianDay 0) False
 
+instance ToJSON User
+instance FromJSON User
+
 data UserPreferences a b c = UserPreferences
   { upId :: a
-  , effortM :: Map a b
-  , priorityM :: Map a b
-  , stateM :: Map a b
+  , effortM :: Map.Map a b
+  , priorityM :: Map.Map a b
+  , stateM :: Map.Map a b
   , theme :: c
-  }
+  } deriving (Eq, Show, Generic)
 
-userPreferences :: Num a => a -> [b] -> [b] -> [b] -> c -> UserPreferences a b c
-userPreferences i efforts priorities states theme = UserPreferences i effortM priorityM stateM theme
+userPreferences :: (Enum a, Num a, Ord a) => a -> [b] -> [b] -> [b] -> c -> UserPreferences a b c
+userPreferences i efforts priorities states thm = UserPreferences i effortM' priorityM' stateM' thm
   where
-      effortM = Map.fromList $ zip [1..] efforts
-      priorityM = Map.fromList $ zip [1..] priorities
-      stateM = Map.fromList $ zip [1..] states
+      effortM' = Map.fromList $ zip [1..] efforts
+      priorityM' = Map.fromList $ zip [1..] priorities
+      stateM' = Map.fromList $ zip [1..] states
 
 emptyUserPreferences :: UserPreferences Int String String
 emptyUserPreferences = userPreferences 0 [] [] [] ""

test/Driver.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}