do some stuff to make it work

src/API.hs

@@ -76,7 +76,7 @@ type MateAPI = "v1" :> (
     :> Patch '[JSON] ()
   :<|> "role" :> AuthProtect "header-auth" :> ReqBody '[JSON] Int
     :> Delete '[JSON] ()
-  :<|> "role" :> "assiciation" :> "list"
+  :<|> "role" :> "association" :> "list"
     :> Get '[JSON] [RoleAssociation]
   :<|> "role" :> "association" :> AuthProtect "header-auth"
     :> ReqBody '[JSON] RoleAssociationSubmit

src/Control/Role.hs

@@ -21,18 +21,19 @@ roleList = do
   conn <- asks rsConnection
   selectAllRoles conn
 
-roleNew = notImpelemented
+roleNew _ _ = notImplemented
 
-roleUpdate = notImpelemented
+roleUpdate _ _ = notImplemented
 
-roleDelete = notImpelemented
+roleDelete _ _ = notImplemented
 
-roleAssociationList = notImpelemented
+roleAssociationList = notImplemented
 
-roleAssociationSubmit = notImpelemented
+roleAssociationSubmit _ _ = notImplemented
 
-roleAssociationDelete = notImpelemented
+roleAssociationDelete _ _ = notImplemented
 
+notImplemented :: MateHandler a
 notImplemented = throwError $ err501
   { errBody = "Function has not yet been implemented!"
   }

src/Control/User.hs

@@ -19,6 +19,7 @@ import qualified Data.Text as T
 
 import Types
 import Model
+import Control.Role
 
 userNew
   :: UserSubmit
@@ -30,7 +31,8 @@ userNew (UserSubmit ident email passhash) = do
   void $ putUserAuthInfo uid PrimaryPass "Initial password" passhash conn
   baseRoleId <- queryRoleIdByCapabilities
     (False, False, False, False, False, False, False, False, False, False, False)
-  void $ assiciateuserToRole uid baseRoleId
+    conn
+  void $ associateUserToRole uid baseRoleId conn
   return uid
 
 userGet

src/Model/Auth.hs

@@ -375,33 +375,13 @@ processAuthRequest (AuthRequest aticket hash) store conn = do
       liftIO $ threadDelay delayTime
       if now > ticketExpiry ticket
       then
-#if defined(DEVELOP)
-        do
-          mockticket <- Ticket <$>
-            pure aticket <*>
-            pure 1 <*>
-            liftIO getCurrentTime <*>
-            pure (PrimaryPass, Nothing)
-          generateToken mockticket hash conn
-#else
         return Denied
-#endif
       else
         -- liftIO $ putStrLn "...and it is valid"
         generateToken ticket hash conn
     _        -> do
       liftIO $ threadDelay delayTime
-#if defined(DEVELOP)
-      do
-        mockticket <- Ticket <$>
-          pure aticket <*>
-          pure 1 <*>
-          liftIO getCurrentTime <*>
-          pure (PrimaryPass, Nothing)
-        generateToken mockticket hash conn
-#else
       return Denied
-#endif
 
 processLogout
   :: Int

src/Model/Role.hs

@@ -8,9 +8,13 @@ import qualified Database.PostgreSQL.Simple as PGS
 
 import Data.Profunctor.Product (p2, p13)
 
+import qualified Data.Text as T
+
 import Opaleye as O hiding (null, not)
 import Opaleye.Constant as C
 
+import Control.Arrow ((<<<))
+
 import Control.Monad
 import Control.Monad.IO.Class (liftIO)
 
@@ -167,7 +171,7 @@ selectAllRoles
 selectAllRoles conn = do
   rawRoles <- liftIO $ runSelect conn (
     queryTable roleTable
-    ) :: Matehandler
+    ) :: MateHandler
         [
           ( Int
           , T.Text
@@ -194,10 +198,10 @@ queryRoleIdByName
   :: T.Text
   -> PGS.Connection
   -> MateHandler Int
-queryRoleIdByName name con = do
+queryRoleIdByName name conn = do
   roles <- liftIO $ runSelect conn (
     keepWhen (\(_, rname, _, _, _, _, _, _, _, _, _, _, _) ->
-      C.constant name == rname) <<< queryTable roleTable
+      C.constant name .== rname) <<< queryTable roleTable
     ) :: MateHandler
         [
           ( Int
@@ -221,45 +225,56 @@ queryRoleIdByCapabilities
   :: (Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool)
   -> PGS.Connection
   -> MateHandler Int
-queryRoleIdByName caps con = do
+queryRoleIdByCapabilities (p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11) conn =
-  roles <- liftIO $ runSelect conn (
+  do
-    keepWhen (\(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11) ->
+    roles <- liftIO $ runSelect conn (
-      C.constant caps == (c1, c2, c3, vc4, c5, c6, c7, c8, c9, c10, c11))
+      keepWhen (\(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11) ->
-        <<< queryTable roleTable
+        C.constant p1 .== c1 .&&
-    ) :: MateHandler
+        C.constant p2 .== c2 .&&
-        [
+        C.constant p3 .== c3 .&&
-          ( Int
+        C.constant p4 .== c4 .&&
-          , T.Text
+        C.constant p5 .== c5 .&&
-          , Bool
+        C.constant p6 .== c6 .&&
-          , Bool
+        C.constant p7 .== c7 .&&
-          , Bool
+        C.constant p8 .== c8 .&&
-          , Bool
+        C.constant p9 .== c9 .&&
-          , Bool
+        C.constant p10 .== c10 .&&
-          , Bool
+        C.constant p11 .== c11
-          , Bool
+        )
-          , Bool
+          <<< queryTable roleTable
-          , Bool
+      ) :: MateHandler
-          , Bool
+          [
-          , Bool
+            ( Int
-          )
+            , T.Text
-        ]
+            , Bool
-  return $ (\(rid, _, _, _, _, _, _, _, _, _, _, _, _) -> rid) (head roles)
+            , Bool
+            , Bool
+            , Bool
+            , Bool
+            , Bool
+            , Bool
+            , Bool
+            , Bool
+            , Bool
+            , Bool
+            )
+          ]
+    return $ (\(rid, _, _, _, _, _, _, _, _, _, _, _, _) -> rid) (head roles)
 
 associateUserToRole
   :: Int             -- ^ User id
   -> Int             -- ^ Role id
   -> PGS.Connection
-  -> Matehandler Int -- ^ Resulting UserToRole id
+  -> MateHandler () -- ^ Resulting UserToRole id
-associateUserToRole uid rid conn = do
+associateUserToRole uid rid conn =
-  a <- runInsert_ conn $ Insert
+  head <$> liftIO (runInsert_ conn $ Insert
     { iTable = userToRoleTable
     , iRows =
       [
-      ( C.constant (Nothing :: Maybe Int)
+      ( C.constant uid
-      , C.constant uid
       , C.constant rid
       )
       ]
-    , iReturning = rReturning (\(id_, _, _) -> id_ )
+    , iReturning = rReturning (const ())
     , iOnConflict = Nothing
-    }
+    })

src/Types/Role.hs

@@ -1,6 +1,10 @@
+{-# LANGUAGE DeriveGeneric #-}
 module Types.Role where
 
 import qualified Data.Text as T
+import Data.Aeson
+
+import GHC.Generics
 
 data Role = Role
   { roleID                 :: Int
@@ -17,6 +21,12 @@ data Role = Role
   , roleCanManageSuppliers :: Bool
   , roleCanManageSettings  :: Bool
   }
+  deriving (Generic, Show)
+
+instance ToJSON Role where
+  toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON Role
 
 data RoleSubmit = RoleSubmit
   { roleSubmitName               :: T.Text
@@ -32,14 +42,32 @@ data RoleSubmit = RoleSubmit
   , roleSubmitCanManageSuppliers :: Bool
   , roleSubmitCanManageSettings  :: Bool
   }
+  deriving (Generic, Show)
+
+instance ToJSON RoleSubmit where
+  toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON RoleSubmit
 
 data RoleAssociation = RoleAssociation
   { roleAssociationId   :: Int
   , roleAssociationUser :: Int
   , roleAssociationRole :: Int
   }
+  deriving (Generic, Show)
+
+instance ToJSON RoleAssociation where
+  toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON RoleAssociation
 
 data RoleAssociationSubmit = RoleAssociationSubmit
   { roleAssociationSubmitUser :: Int
   , roleAssociationSubmitRole :: Int
   }
+  deriving (Generic, Show)
+
+instance ToJSON RoleAssociationSubmit where
+  toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON RoleAssociationSubmit