mateamt/src/Types/Auth.hs

232 lines
5.3 KiB
Haskell
Raw Normal View History

2019-04-17 05:51:15 +00:00
{-# LANGUAGE DeriveGeneric #-}
2019-04-17 08:45:48 +00:00
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeFamilies #-}
2019-04-17 05:51:15 +00:00
module Types.Auth where
import GHC.Generics
import Data.Aeson
2019-04-21 15:27:15 +00:00
import qualified Data.Set as S
import Data.Time.Clock (UTCTime)
import Data.ByteString (ByteString)
2022-07-17 19:28:22 +00:00
import Data.OpenApi
import qualified Data.Text as T
import Data.Text.Encoding
2019-04-17 05:51:15 +00:00
2019-05-06 21:41:05 +00:00
import Control.Concurrent.STM.TVar (TVar)
2019-04-21 15:27:15 +00:00
-- internal imports
import Classes
data TicketRequest = TicketRequest
{ ticketRequestUser :: Int
, ticketRequestMethod :: AuthMethod
}
deriving (Show, Generic)
instance ToJSON TicketRequest where
toEncoding = genericToEncoding defaultOptions
instance FromJSON TicketRequest
2022-07-17 19:28:22 +00:00
instance ToSchema TicketRequest
2019-04-17 05:51:15 +00:00
data AuthInfo = AuthInfo
{ authChallenge :: Maybe T.Text
2019-04-21 15:27:15 +00:00
, authTicket :: AuthTicket
2019-04-17 05:51:15 +00:00
}
deriving (Show, Generic)
instance ToJSON AuthInfo where
2019-07-27 14:34:28 +00:00
toEncoding = genericToEncoding defaultOptions
2019-04-17 05:51:15 +00:00
instance FromJSON AuthInfo
2022-07-17 19:28:22 +00:00
instance ToSchema AuthInfo
2019-04-17 05:51:15 +00:00
-- instance ToDatabase AuthInfo where
--
-- type InTuple AuthInfo = (Maybe T.Text, T.Text)
--
-- toDatabase (AuthInfo mChallenge (AuthTicket ticket)) =
-- (mChallenge, ticket)
instance FromDatabase AuthInfo where
type OutTuple AuthInfo = (Maybe ByteString, ByteString)
fromDatabase (mChallenge, ticket) =
AuthInfo (decodeUtf8 <$> mChallenge) (AuthTicket $ decodeUtf8 ticket)
2019-05-13 20:50:24 +00:00
data AuthMethod
= PrimaryPass
| SecondaryPass
| ChallengeResponse
deriving (Show, Generic, Enum, Eq, Ord)
2019-04-17 05:51:15 +00:00
instance ToJSON AuthMethod where
toEncoding = genericToEncoding defaultOptions
2019-04-17 05:51:15 +00:00
instance FromJSON AuthMethod
2019-04-17 05:51:15 +00:00
2022-07-17 19:28:22 +00:00
instance ToSchema AuthMethod
instance ToParamSchema AuthMethod
2019-05-13 20:50:24 +00:00
2019-09-16 06:59:57 +00:00
data AuthSubmit = AuthSubmit
{ authSubmitMethod :: AuthMethod
, authSubmitComment :: T.Text
, authSubmitPayload :: T.Text
}
deriving (Show, Generic)
instance ToJSON AuthSubmit where
toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthSubmit
2022-07-17 19:28:22 +00:00
instance ToSchema AuthSubmit
2019-09-16 06:59:57 +00:00
newtype AuthTicket = AuthTicket T.Text deriving (Show, Generic, Eq, Ord)
2019-04-21 15:27:15 +00:00
instance ToJSON AuthTicket where
toEncoding = genericToEncoding defaultOptions
2019-04-17 08:45:48 +00:00
instance FromJSON AuthTicket
2022-07-17 19:28:22 +00:00
instance ToSchema AuthTicket
2019-05-13 20:50:24 +00:00
newtype AuthResponse = AuthResponse T.Text deriving (Show, Generic)
2019-04-17 05:51:15 +00:00
instance ToJSON AuthResponse where
toEncoding = genericToEncoding defaultOptions
2019-04-17 08:45:48 +00:00
instance FromJSON AuthResponse
2022-07-17 19:28:22 +00:00
instance ToSchema AuthResponse
2019-05-13 20:50:24 +00:00
2019-04-17 05:51:15 +00:00
data AuthRequest = AuthRequest
2022-04-17 14:38:48 +00:00
{ authRequestTicket :: AuthTicket
, authRequestPassword :: AuthResponse
2019-04-17 05:51:15 +00:00
}
deriving (Show, Generic)
instance ToJSON AuthRequest where
2019-04-17 08:45:48 +00:00
toEncoding = genericToEncoding defaultOptions
2019-04-17 05:51:15 +00:00
instance FromJSON AuthRequest
2022-07-17 19:28:22 +00:00
instance ToSchema AuthRequest
2019-05-13 20:50:24 +00:00
2019-04-17 05:51:15 +00:00
data AuthResult
= Granted
2019-05-09 14:53:19 +00:00
{ authToken :: AuthToken
2019-04-17 05:51:15 +00:00
}
| Denied
deriving (Show, Generic)
instance ToJSON AuthResult where
2019-04-17 08:45:48 +00:00
toEncoding = genericToEncoding defaultOptions
2019-04-17 05:51:15 +00:00
instance FromJSON AuthResult
2022-07-17 19:28:22 +00:00
instance ToSchema AuthResult
2019-05-13 20:50:24 +00:00
newtype AuthToken = AuthToken T.Text deriving (Show, Generic)
2019-04-17 08:45:48 +00:00
instance ToJSON AuthToken where
toEncoding = genericToEncoding defaultOptions
2019-04-17 08:45:48 +00:00
instance FromJSON AuthToken
2022-07-17 19:28:22 +00:00
instance ToSchema AuthToken
2019-05-13 20:50:24 +00:00
2019-04-21 15:27:15 +00:00
data Token = Token
{ tokenString :: T.Text
2019-04-21 15:27:15 +00:00
, tokenUser :: Int
, tokenExpiry :: UTCTime
, tokenMethod :: AuthMethod
2019-04-21 15:27:15 +00:00
}
deriving (Generic, Show)
-- instance ToDatabase Token where
--
-- type InTuple Token = (T.Text, Int, UTCTime, Int)
--
-- toDatabase (Token string usr exp method) =
-- (string, usr, exp, fromEnum method)
instance FromDatabase Token where
type OutTuple Token = (ByteString, Int, UTCTime, Int)
2021-07-12 11:29:40 +00:00
fromDatabase (string, usr, expiry, method) =
Token (decodeUtf8 string) usr expiry (toEnum method)
2019-05-13 20:50:24 +00:00
2019-05-06 21:41:05 +00:00
type TicketStore = TVar (S.Set Ticket)
2019-04-21 15:27:15 +00:00
2019-05-13 20:50:24 +00:00
2019-04-21 15:27:15 +00:00
data Ticket = Ticket
{ ticketId :: AuthTicket
, ticketUser :: Int
, ticketExpiry :: UTCTime
2019-09-15 09:01:47 +00:00
, ticketMethod :: (AuthMethod, Maybe T.Text)
2019-04-21 15:27:15 +00:00
}
deriving (Show, Ord)
2019-04-21 15:27:15 +00:00
instance Eq Ticket where
(Ticket i1 _ _ _) == (Ticket i2 _ _ _) = i1 == i2
data AuthData = AuthData
{ authDataId :: Int
, authDataUser :: Int
, authDataMethod :: AuthMethod
2019-09-16 06:59:57 +00:00
, authDataComment :: T.Text
2019-09-15 09:01:47 +00:00
, authDataPayload :: T.Text
2022-04-17 14:38:48 +00:00
, authDataSalt :: T.Text
}
deriving (Show)
2019-09-16 06:59:57 +00:00
-- instance ToDatabase AuthData where
--
-- type InTuple AuthData = (Int, Int, Int, T.Text, ByteString)
--
-- toDatabase (AuthData id_ usr method comm payload) =
-- (id_, usr, fromEnum method, comm, (B64.decode $ encodeUtf8 payload))
instance FromDatabase AuthData where
2022-04-17 14:38:48 +00:00
type OutTuple AuthData = (Int, Int, Int, T.Text, ByteString, ByteString)
2022-04-17 14:38:48 +00:00
fromDatabase (id_, usr, method, comm, payload, salt) =
AuthData id_ usr (toEnum method) comm (decodeUtf8 payload) (decodeUtf8 salt)
2019-09-16 06:59:57 +00:00
data AuthOverview = AuthOverview
{ authOverviewId :: Int
2021-06-16 16:09:08 +00:00
, authOverviewUser :: Int
2019-09-16 06:59:57 +00:00
, authOverviewComment :: T.Text
, authOverviewMethod :: AuthMethod
}
deriving (Show, Generic)
instance ToJSON AuthOverview where
toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthOverview
2022-07-17 19:28:22 +00:00
instance ToSchema AuthOverview
-- instance ToDatabase AuthOverview where
--
-- type InTuple AuthOverview = (Int, T.Text, Int)
--
-- toDatabase (AuthOverview id_ comm method) =
-- (id_, comm, fromEnum method)
instance FromDatabase AuthOverview where
2021-06-16 16:09:08 +00:00
type OutTuple AuthOverview = (Int, Int, T.Text, Int)
2021-06-16 16:09:08 +00:00
fromDatabase (id_, uid, comm, method) =
AuthOverview id_ uid comm (toEnum method)