mateamt/src/Types/Auth.hs

147 lines
3 KiB
Haskell

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Types.Auth where
import GHC.Generics
import Data.Aeson
import Data.ByteString
import qualified Data.ByteString.Base16 as B16
import qualified Data.Set as S
import Data.Time.Clock (UTCTime)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Control.Concurrent.STM.TVar (TVar)
-- internal imports
data AuthInfo = AuthInfo
{ authSalt :: AuthSalt
, authAlgorithm :: AuthAlgorithm
, authTicket :: AuthTicket
}
deriving (Show, Generic)
instance ToJSON AuthInfo where
toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthInfo
data AuthAlgorithm
= SHA3_512
deriving (Show, Read, Generic, Enum)
instance ToJSON AuthAlgorithm where
toJSON = toJSON . show
instance FromJSON AuthAlgorithm where
parseJSON j = read <$> parseJSON j
newtype AuthTicket = AuthTicket ByteString deriving (Show, Eq, Ord)
instance ToJSON AuthTicket where
toJSON (AuthTicket bs) = (String . decodeUtf8 . B16.encode) bs
instance FromJSON AuthTicket where
parseJSON = withText ""
(\t -> do
let enc = fst $ B16.decode $ encodeUtf8 t
return (AuthTicket enc)
)
newtype AuthSalt = AuthSalt ByteString deriving (Show)
instance ToJSON AuthSalt where
toJSON (AuthSalt bs) = (String . decodeUtf8 . B16.encode) bs
instance FromJSON AuthSalt where
parseJSON = withText ""
(\t -> do
let enc = fst $ B16.decode $ encodeUtf8 t
return (AuthSalt enc)
)
newtype AuthHash = AuthHash ByteString deriving (Show)
instance ToJSON AuthHash where
toJSON (AuthHash bs) = (String . decodeUtf8 . B16.encode) bs
instance FromJSON AuthHash where
parseJSON = withText ""
(\t -> do
let enc = fst $ B16.decode $ encodeUtf8 t
return (AuthHash enc)
)
data AuthRequest = AuthRequest
{ authRequestTicket :: AuthTicket
, authRequestHash :: AuthHash
}
deriving (Show, Generic)
instance ToJSON AuthRequest where
toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthRequest
data AuthResult
= Granted
{ authToken :: AuthToken
}
| Denied
deriving (Show, Generic)
instance ToJSON AuthResult where
toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthResult
newtype AuthToken = AuthToken ByteString deriving (Show)
instance ToJSON AuthToken where
toJSON (AuthToken bs) = (String . decodeUtf8 . B16.encode) bs
instance FromJSON AuthToken where
parseJSON = withText ""
(\t -> do
let enc = fst $ B16.decode $ encodeUtf8 t
return (AuthToken enc)
)
data Token = Token
{ tokenString :: ByteString
, tokenUser :: Int
, tokenExpiry :: UTCTime
}
deriving (Generic, Show)
instance ToJSON Token where
toJSON (Token s _ _) = (String . decodeUtf8 . B16.encode) s
type TicketStore = TVar (S.Set Ticket)
data Ticket = Ticket
{ ticketId :: AuthTicket
, ticketUser :: Int
, ticketExpiry :: UTCTime
}
deriving (Ord)
instance Eq Ticket where
(Ticket i1 _ _) == (Ticket i2 _ _) = i1 == i2