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.IORef
|
|
|
|
|
|
|
|
import Control.Monad.IO.Class (liftIO)
|
|
|
|
|
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
|
|
|
|
|
|
|
|
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
|
|
|
|
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
|