mateamt/src/Types/Auth.hs

140 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-04-21 15:27:15 +00:00
import Data.StateVar
import Data.IORef
import Control.Monad.IO.Class (liftIO)
-- 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
instance FromJSON AuthInfo
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-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-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)
)
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
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
data AuthResult
= Granted
2019-04-21 15:27:15 +00:00
{ authToken :: Token
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
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
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 = StateVar (S.Set Ticket)
{-# NOINLINE ticketStore #-}
data Ticket = Ticket
{ ticketId :: AuthTicket
, ticketUser :: Int
, ticketExpiry :: UTCTime
}
deriving (Ord)
instance Eq Ticket where
(Ticket i1 _ _) == (Ticket i2 _ _) = i1 == i2