{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} module Types.Auth where import GHC.Generics import Control.Lens.Lens import Crypto.JWT import Data.Aeson import qualified Data.Set as S import Data.Time.Clock (UTCTime) import Data.ByteString (ByteString) import Data.OpenApi import qualified Data.Text as T import Data.Text.Encoding import Control.Concurrent.STM.TVar (TVar) -- internal imports import Classes data TicketRequest = TicketRequest { ticketRequestUser :: Int , ticketRequestMethod :: AuthMethod } deriving (Show, Generic) instance ToJSON TicketRequest where toEncoding = genericToEncoding defaultOptions instance FromJSON TicketRequest instance ToSchema TicketRequest data AuthInfo = AuthInfo { authChallenge :: Maybe T.Text , authTicket :: AuthTicket } deriving (Show, Generic) instance ToJSON AuthInfo where toEncoding = genericToEncoding defaultOptions instance FromJSON AuthInfo instance ToSchema AuthInfo -- instance ToDatabase AuthInfo where -- -- type InTuple AuthInfo = (Maybe T.Text, T.Text) -- -- toDatabase (AuthInfo mChallenge (AuthTicket ticket)) = -- (mChallenge, ticket) instance DatabaseRepresentation AuthInfo where type Representation AuthInfo = (Maybe ByteString, ByteString) instance FromDatabase AuthInfo where fromDatabase (mChallenge, ticket) = AuthInfo (decodeUtf8 <$> mChallenge) (AuthTicket $ decodeUtf8 ticket) data AuthMethod = PrimaryPass | SecondaryPass | ChallengeResponse deriving (Show, Generic, Enum, Eq, Ord) instance ToJSON AuthMethod where toEncoding = genericToEncoding defaultOptions instance FromJSON AuthMethod instance ToSchema AuthMethod instance ToParamSchema AuthMethod data AuthSubmit = AuthSubmit { authSubmitMethod :: AuthMethod , authSubmitComment :: T.Text , authSubmitPayload :: T.Text } deriving (Show, Generic) instance ToJSON AuthSubmit where toEncoding = genericToEncoding defaultOptions instance FromJSON AuthSubmit instance ToSchema AuthSubmit newtype AuthTicket = AuthTicket T.Text deriving (Show, Generic, Eq, Ord) instance ToJSON AuthTicket where toEncoding = genericToEncoding defaultOptions instance FromJSON AuthTicket instance ToSchema AuthTicket newtype AuthResponse = AuthResponse T.Text deriving (Show, Generic) instance ToJSON AuthResponse where toEncoding = genericToEncoding defaultOptions instance FromJSON AuthResponse instance ToSchema AuthResponse data AuthRequest = AuthRequest { authRequestUser :: Int , authRequestMethod :: AuthMethod , authRequestPassword :: AuthResponse } deriving (Show, Generic) instance ToJSON AuthRequest where toEncoding = genericToEncoding defaultOptions instance FromJSON AuthRequest instance ToSchema AuthRequest data AuthResult = AuthResult { authTime :: UTCTime , authUser :: Int , authMethod :: AuthMethod -- , authToken :: AuthToken } deriving (Show, Generic) instance ToJSON AuthResult where toEncoding = genericToEncoding defaultOptions instance FromJSON AuthResult instance ToSchema AuthResult instance HasClaimsSet AuthResult where claimsSet = lens (const emptyClaimsSet) const instance FromJSON Token instance ToSchema Token newtype AuthToken = AuthToken T.Text deriving (Show, Generic) instance ToJSON AuthToken where toEncoding = genericToEncoding defaultOptions instance FromJSON AuthToken instance ToSchema AuthToken data Token = Token { tokenId :: Int , tokenUser :: Int , tokenExpiry :: UTCTime , tokenMethod :: AuthMethod } 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 DatabaseRepresentation Token where type Representation Token = (Int, Int, UTCTime, Int) instance FromDatabase Token where fromDatabase (tId, usr, expiry, method) = Token tId usr expiry (toEnum method) type TicketStore = TVar (S.Set Ticket) data Ticket = Ticket { ticketId :: AuthTicket , ticketUser :: Int , ticketExpiry :: UTCTime , ticketMethod :: (AuthMethod, Maybe T.Text) } deriving (Show, Ord) instance Eq Ticket where (Ticket i1 _ _ _) == (Ticket i2 _ _ _) = i1 == i2 data AuthData = AuthData { authDataId :: Int , authDataUser :: Int , authDataMethod :: AuthMethod , authDataComment :: T.Text , authDataPayload :: T.Text , authDataSalt :: T.Text } deriving (Show) -- 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 DatabaseRepresentation AuthData where type Representation AuthData = (Int, Int, Int, T.Text, ByteString, ByteString) instance FromDatabase AuthData where fromDatabase (id_, usr, method, comm, payload, salt) = AuthData id_ usr (toEnum method) comm (decodeUtf8 payload) (decodeUtf8 salt) data AuthOverview = AuthOverview { authOverviewId :: Int , authOverviewUser :: Int , authOverviewComment :: T.Text , authOverviewMethod :: AuthMethod } deriving (Show, Generic) instance ToJSON AuthOverview where toEncoding = genericToEncoding defaultOptions instance FromJSON AuthOverview instance ToSchema AuthOverview -- instance ToDatabase AuthOverview where -- -- type InTuple AuthOverview = (Int, T.Text, Int) -- -- toDatabase (AuthOverview id_ comm method) = -- (id_, comm, fromEnum method) instance DatabaseRepresentation AuthOverview where type Representation AuthOverview = (Int, Int, T.Text, Int) instance FromDatabase AuthOverview where fromDatabase (id_, uid, comm, method) = AuthOverview id_ uid comm (toEnum method)