foobar

.gitignore

@@ -1,5 +1,6 @@
 *.swp
 dist-newstyle/
+dist/
 *.hp
 *.ps
 *.pdf

mateamt.cabal

@@ -22,6 +22,8 @@ executable mateamt
                      , Model.User
                      , Model.Beverage
                      , Types
+                     , Types.Refine
+                     , Types.Auth
   -- other-extensions:
   build-depends:       base ^>=4.12.0.0
                      , servant
@@ -36,5 +38,6 @@ executable mateamt
                      , wai
                      , wai-logger
                      , http-api-data
+                     , bytestring
   hs-source-dirs:      src
   default-language:    Haskell2010

shell.nix

@@ -4,9 +4,9 @@ let
 
   inherit (nixpkgs) pkgs;
 
-  f = { mkDerivation, aeson, base, opaleye, postgresql-simple
-      , product-profunctors, servant, servant-server, stdenv, text, time
-      , warp
+  f = { mkDerivation, aeson, base, bytestring, http-api-data
+      , opaleye, postgresql-simple, product-profunctors, servant
+      , servant-server, stdenv, text, time, wai, wai-logger, warp
       }:
       mkDerivation {
         pname = "mateamt";
@@ -15,8 +15,9 @@ let
         isLibrary = false;
         isExecutable = true;
         executableHaskellDepends = [
-          aeson base opaleye postgresql-simple product-profunctors servant
-          servant-server text time warp
+          aeson base bytestring http-api-data opaleye postgresql-simple
+          product-profunctors servant servant-server text time wai wai-logger
+          warp
         ];
         description = "A whole new matemat";
         license = stdenv.lib.licenses.agpl3;

src/API.hs

@@ -23,7 +23,12 @@ import Types
 
 type UserAPI =
   "user" :>
-    ( "list" :> QueryParam "refine" Refine :> Get '[JSON] [User]
+    ( "list" :> QueryParam "refine" Refine
+      :> AuthProtect "header-auth" :> Get '[JSON] [User]
     :<|> "new" :> ReqBody '[JSON] UserSubmit :> Post '[JSON] Int
     :<|> "update" :> ReqBody '[JSON] (Int, UserSubmit) :> Post '[JSON] ()
     )
+  :<|> "auth" :> 
+    ( "get" :> ReqBody '[JSON] Int :> Post '[JSON] AuthInfo
+    :<|> "send" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult
+    )

src/Main.hs

@@ -1,7 +1,11 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 module Main where
 
 import Servant
+import Servant.Server.Experimental.Auth
 
 import Data.Time.Clock
 
@@ -35,19 +39,34 @@ main = do
     runSettings settings (app conn)
 
 app :: Connection -> Application
-app conn = serve userApi (users conn)
+app conn = serveWithContext userApi genAuthServerContext (users conn)
 
 userApi :: Proxy UserAPI
 userApi = Proxy
 
+genAuthServerContext :: Context (AuthHandler Request Bool ': '[])
+genAuthServerContext = authHandler Servant.:. EmptyContext
+
+type instance AuthServerData (AuthProtect "header-auth") = Bool
+
+authHandler :: AuthHandler Request Bool
+authHandler = mkAuthHandler handler
+  where
+    handler req = do
+      let headers = requestHeaders req
+          res = case lookup "Authorization" headers of
+            Just _ -> True
+            _      -> False
+      return res
+
 users :: Connection -> Server UserAPI
 users conn =
   userList :<|>
   userNew :<|>
   userUpdate
   where
-    userList :: Maybe Refine -> Handler [User]
-    userList ref = liftIO $ userSelect conn ref
+    userList :: Maybe Refine -> Bool -> Handler [User]
+    userList ref sw = liftIO $ userSelect conn ref sw
     userNew :: UserSubmit -> Handler Int
     userNew  us = liftIO $ do
       now <- getCurrentTime

src/Model/User.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 module Model.User where
 
 import Data.Text as T
@@ -24,18 +25,24 @@ import qualified Opaleye.Constant as C
 
 -- internal imports
 
-import Types
+import Types.Refine
 
-data User = User
-  { userId        :: Int
-  , userIdent     :: T.Text
-  , userBalance   :: Int
-  , userTimeStamp :: Day
-  , userEmail     :: Maybe T.Text
-  , userAvatar    :: Maybe Int
-  , userPin       :: Maybe T.Text
-  }
-    deriving (Generic, Show)
+data User
+  = User
+    { userId        :: Int
+    , userIdent     :: T.Text
+    , userBalance   :: Int
+    , userTimeStamp :: Day
+    , userEmail     :: Maybe T.Text
+    , userAvatar    :: Maybe Int
+    , userPin       :: Maybe T.Text
+    }
+  | QueryUser
+    { userId        :: Int
+    , userIdent     :: T.Text
+    , userAvatar    :: Maybe Int
+    }
+  deriving (Generic, Show)
 
 instance ToJSON User where
   toEncoding (User id ident balance ts email avatar _) =
@@ -47,6 +54,12 @@ instance ToJSON User where
       <> "userEmail" .= email
       <> "userAvatar" .= avatar
       )
+  toEncoding (QueryUser id ident avatar) =
+    pairs
+      (  "userId" .= id
+      <> "userIdent" .= ident
+      <> "userAvatar" .= avatar
+      )
 
 instance FromJSON User
 
@@ -97,21 +110,11 @@ userTable = table "user" (
 userSelect
   :: PGS.Connection
   -> Maybe Refine
+  -> Bool
   -> IO [User]
-userSelect conn ref = do
+userSelect conn ref sw = do
   today <- utctDay <$> getCurrentTime
-  (mapM
-    (\(i1, i2, i3, i4, i5, i6, i7) -> return $
-      User
-        i1
-        i2
-        i3
-        i4
-        i5
-        i6
-        i7
-      )
-    ) =<< runSelect conn (case ref of
+  users <- runSelect conn (case ref of
       Nothing -> keepWhen (\(_, _, _, ts, _, _, _) ->
         ts .>= C.constant (addDays (-30) today)
         ) <<< queryTable userTable
@@ -119,7 +122,14 @@ userSelect conn ref = do
       Just Old -> keepWhen (\(_, _, _, ts, _, _, _) ->
         ts .<= C.constant (addDays (-30) today)
         ) <<< queryTable userTable
+      ) :: IO [(Int, Text, Int, Day, Maybe Text, Maybe Int, Maybe Text)]
+  mapM
+    (\(i1, i2, i3, i4, i5, i6, i7) -> return $
+      if sw
+      then User i1 i2 i3 i4 i5 i6 i7
+      else QueryUser i1 i2 i6
       )
+    users
 
 insertUser :: UserSubmit -> Day -> Insert [Int]
 insertUser us now = Insert

src/Types.hs

@@ -1,20 +1,6 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
+module Types
+  ( module T
+  ) where
 
-module Types where
-
-import Data.Text
-
-import GHC.Generics
-
-import Web.HttpApiData
-
-data Refine = All | Old
-  deriving (Generic, Show, Enum)
-
-instance FromHttpApiData Refine where
-  parseQueryParam t =
-    case t of
-      "all" -> Right All
-      "old" -> Right Old
-      x     -> Left ("Error: Unknown refine " <> x)
+import Types.Refine as T
+import Types.Auth as T

src/Types/Auth.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Types.Auth where
+
+import GHC.Generics
+
+import Data.Aeson
+
+import Data.ByteString
+
+data AuthInfo = AuthInfo
+  { authSalt :: AuthSalt
+  , authAlgorithm :: AuthAlgorithm
+  }
+  deriving (Show, Generic)
+
+instance ToJSON AuthInfo where
+    toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON AuthInfo
+
+data AuthAlgorithm
+  = PBKDF2
+    deriving (Show, Generic)
+
+instance ToJSON AuthAlgorithm where
+    toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON AuthAlgorithm
+
+type AuthSalt = ByteString
+
+instance ToJSON AuthSalt where
+    toJSON salt = object (toHex salt)
+
+instance FromJSON AuthSalt
+
+data AuthRequest = AuthRequest
+  { requestUser :: Int
+  , requestHash :: ByteString
+  }
+  deriving (Show, Generic)
+
+instance ToJSON AuthRequest where
+    toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON AuthRequest
+
+data AuthResult
+  = Granted
+    { authToken :: ByteString
+    }
+  | Denied
+    deriving (Show, Generic)
+
+instance ToJSON AuthResult where
+    toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON AuthResult

src/Types/Refine.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Types.Refine where
+
+import Data.Text
+
+import GHC.Generics
+
+import Web.HttpApiData
+
+data Refine = All | Old
+  deriving (Generic, Show, Enum)
+
+instance FromHttpApiData Refine where
+  parseQueryParam t =
+    case t of
+      "all" -> Right All
+      "old" -> Right Old
+      x     -> Left ("Error: Unknown refine " <> x)