mateamt/src/Types/Auth.hs

147 lines
3 KiB
Haskell
Raw Normal View History

2019-04-17 05:51:15 +00:00
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
2019-04-17 08:45:48 +00:00
{-# LANGUAGE TypeSynonymInstances #-}
2019-04-17 05:51:15 +00:00
module Types.Auth where
import GHC.Generics
import Data.Aeson
import Data.ByteString
2019-04-17 08:45:48 +00:00
import qualified Data.ByteString.Base16 as B16
2019-04-21 15:27:15 +00:00
import qualified Data.Set as S
import Data.Time.Clock (UTCTime)
2019-04-17 08:45:48 +00:00
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
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
2019-04-17 05:51:15 +00:00
data AuthInfo = AuthInfo
2019-04-21 15:27:15 +00:00
{ authSalt :: AuthSalt
2019-04-17 05:51:15 +00:00
, authAlgorithm :: AuthAlgorithm
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
2019-05-13 20:50:24 +00:00
2019-04-17 05:51:15 +00:00
data AuthAlgorithm
2019-04-21 15:27:15 +00:00
= SHA3_512
2019-04-17 09:09:49 +00:00
deriving (Show, Read, Generic, Enum)
2019-04-17 05:51:15 +00:00
instance ToJSON AuthAlgorithm where
2019-04-17 09:09:49 +00:00
toJSON = toJSON . show
2019-04-17 05:51:15 +00:00
2019-04-17 09:09:49 +00:00
instance FromJSON AuthAlgorithm where
parseJSON j = read <$> parseJSON j
2019-04-17 05:51:15 +00:00
2019-05-13 20:50:24 +00:00
2019-04-21 15:27:15 +00:00
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)
)
2019-05-13 20:50:24 +00:00
2019-04-17 08:45:48 +00:00
newtype AuthSalt = AuthSalt ByteString deriving (Show)
2019-04-17 05:51:15 +00:00
instance ToJSON AuthSalt where
2019-04-17 08:45:48 +00:00
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)
)
2019-05-13 20:50:24 +00:00
2019-04-17 08:45:48 +00:00
newtype AuthHash = AuthHash ByteString deriving (Show)
2019-04-17 05:51:15 +00:00
2019-04-17 08:45:48 +00:00
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)
)
2019-04-17 05:51:15 +00:00
2019-05-13 20:50:24 +00:00
2019-04-17 05:51:15 +00:00
data AuthRequest = AuthRequest
2019-04-21 15:27:15 +00:00
{ authRequestTicket :: AuthTicket
, authRequestHash :: AuthHash
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
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
2019-05-13 20:50:24 +00:00
2019-04-17 08:45:48 +00:00
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)
)
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 Token = Token
{ tokenString :: ByteString
, tokenUser :: Int
, tokenExpiry :: UTCTime
}
deriving (Generic, Show)
instance ToJSON Token where
toJSON (Token s _ _) = (String . decodeUtf8 . B16.encode) s
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
}
deriving (Ord)
instance Eq Ticket where
(Ticket i1 _ _) == (Ticket i2 _ _) = i1 == i2