{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
module LuminescentDreams.AuthDB (
    AuthException(..), Username(..), Password(..)
  , Expiration(..), TokenId(..), AuthToken(..), AuthDB
  , AuthDBM
  , runAuthDB, runAuthDBE
  , connectAuthDB, initializeAuthDB
  , authenticateUser, listUsers, listTokens
  , setPassword, createToken, exchangeToken, checkPassword, checkToken
  , saveDatabase, PWHash(..)
  ) where

import            Data.Aeson              ( FromJSON(..), ToJSON(..), Value(..)
                                          , (.=), (.:)
                                          , eitherDecode, encode, object
                                          )
import            Control.Exception       (IOException, try)
import            Control.Monad.Except    (MonadError(..), ExceptT(..), runExceptT)
import            Control.Monad.IO.Class  (MonadIO, liftIO)
import            Control.Monad.Reader    (MonadReader(..), ReaderT(..), runReaderT)
import qualified  Crypto.BCrypt           as BCrypt
import qualified  Data.ByteString         as BS
import qualified  Data.ByteString.Base64  as Base64
import qualified  Data.ByteString.Lazy    as BSL
import            Data.IORef              (IORef, newIORef, modifyIORef, readIORef)
import qualified  Data.Map                as M
import qualified  Data.Text               as TS
import qualified  Data.Text.Encoding      as TS
import qualified  Data.Text.Lazy          as T
import            Data.Time
import qualified  Data.UUID               as UUID
import            System.Directory
import            System.Random


data AuthException = HashFailure
                   | ParseException String
                   | InvalidPassword
                   | InvalidToken
                   | IOException IOException
                   deriving (Eq, Show)

newtype Username    = Username TS.Text                        deriving (Eq, Ord, Show)
newtype Password    = Password TS.Text                        deriving (Eq, Show)
newtype PWHash      = PWHash BS.ByteString                    deriving (Eq, Show)
newtype Expiration  = Expiration UTCTime                      deriving (Eq, Ord, Show)
newtype TokenId     = TokenId UUID.UUID                       deriving (Eq, Ord, Show)
data    AuthToken   = AuthToken Username Expiration TokenId   deriving (Eq, Ord, Show)

data AuthDB = AuthDB FilePath (IORef AuthDB_)

data AuthDB_ = AuthDB_ { usermap :: M.Map Username PWHash
                       , tokenmap :: M.Map TokenId AuthToken
                       , grantmap :: M.Map TokenId Expiration
                       }

newtype AuthDBM a = AuthDBM (ReaderT AuthDB (ExceptT AuthException IO) a)
  deriving ( Functor, Applicative, Monad, MonadIO
           , MonadError AuthException, MonadReader AuthDB
           )

-- secret :: BS.ByteString
-- secret = "one secret to be used"

timeToLive :: NominalDiffTime
timeToLive = fromRational $ toRational $ secondsToDiffTime 3600 * 24 * 7

grantTimeToLive :: NominalDiffTime
grantTimeToLive = fromRational $ toRational $ secondsToDiffTime 5 * 60

hashingPolicy :: BCrypt.HashingPolicy
hashingPolicy = BCrypt.HashingPolicy 12 "$2y$"
-- hashingPolicyStr :: BS.ByteString
-- hashingPolicyStr = "$2y$12$"

-- instance FromJSON AuthDB where
--   parseJSON = undefined
--
-- instance ToJSON AuthDB where
--   toJSON = undefined


runAuthDB :: AuthDB -> AuthDBM a -> IO (Either AuthException a)
runAuthDB db = runExceptT . runAuthDBE db

runAuthDBE :: AuthDB -> AuthDBM a -> ExceptT AuthException IO a
runAuthDBE db (AuthDBM act) = runReaderT act db

connectAuthDB :: (MonadIO m) => FilePath -> m (Either AuthException AuthDB)
connectAuthDB path = liftIO $ do
  -- TODO: once data can me persisted to disk, be ready to load or create the DB from an on-disk file
  exists <- doesFileExist path
  if exists
    then runExceptT $ loadDatabase path
    else do
      dbref <- newIORef (AuthDB_ M.empty M.empty M.empty)
      return $ Right $ AuthDB path dbref


initializeAuthDB :: (MonadIO m) => FilePath -> M.Map Username PWHash -> m (Either AuthException AuthDB)
initializeAuthDB path initialDB =
  liftIO $ newIORef (AuthDB_ initialDB M.empty M.empty) >>= return . Right . AuthDB path


authenticateUser :: Username -> Password -> AuthDBM (Maybe AuthToken)
authenticateUser username password = do
  valid <- checkPassword username password
  if valid
    then Just `fmap` createToken username
    else return Nothing


listUsers :: AuthDBM [Username]
listUsers = do
  AuthDB_{..} <- ask >>= \(AuthDB _ dbref) -> tryIO $ readIORef dbref
  return $ M.keys usermap


listTokens :: AuthDBM [AuthToken]
listTokens = do
  AuthDB_{..} <- ask >>= \(AuthDB _ dbref) -> tryIO $ readIORef dbref
  return $ M.elems tokenmap


setPassword :: Username -> Password -> AuthDBM ()
setPassword username password = do
  AuthDB _ dbref <- ask
  hash <- tryIO $ hashPassword password
  case hash of
    Nothing -> throwError HashFailure
    Just hash_ -> do
      tryIO $ modifyIORef dbref (\db -> db { usermap = M.insert username hash_ (usermap db) })
      saveDatabase


checkPassword :: Username -> Password -> AuthDBM Bool
checkPassword username (Password pass) = do
  AuthDB_{..} <- ask >>= \(AuthDB _ dbref) -> tryIO $ readIORef dbref
  case M.lookup username usermap of
    Nothing -> return False
    Just (PWHash hash) -> return $ BCrypt.validatePassword hash (TS.encodeUtf8 pass)


createToken :: Username -> AuthDBM AuthToken
createToken username = do
  AuthDB _ dbref <- ask
  now <- tryIO getTimeNearestSecond
  let expiration = (Expiration . addUTCTime timeToLive) now
  let grantExpiration = (Expiration . addUTCTime grantTimeToLive) now
  uuid <- liftIO $ TokenId `fmap` randomIO
  let token = AuthToken username expiration uuid
  tryIO $ modifyIORef dbref (\db -> db { tokenmap = M.insert uuid token (tokenmap db)
                                       , grantmap = M.insert uuid grantExpiration (grantmap db)
                                       })
  saveDatabase
  return token


exchangeToken :: TokenId -> AuthDBM (Maybe AuthToken)
exchangeToken tokenId = do
  AuthDB _ dbref <- ask
  AuthDB_{..} <- tryIO $ readIORef dbref
  now <- tryIO getTimeNearestSecond
  case M.lookup tokenId grantmap of
    Nothing -> return Nothing
    Just (Expiration expiration) -> do
      tryIO $ modifyIORef dbref (\db -> db { grantmap = M.delete tokenId grantmap })
      if now >= expiration
        then return Nothing
        else return (M.lookup tokenId tokenmap)


  -- where
    -- hash :: BS.ByteString -> BS.ByteString
    -- hash text = BS.fromString (show (Hash.hash text :: Hash.Digest Hash.SHA256))
    -- expiration :: UTCTime -> UTCTime
    -- expiration t = addUTCTime timeToLive t
    -- timeStr :: UTCTime -> BS.ByteString
    -- timeStr = BS.fromString . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S"
    -- content :: BS.ByteString
    -- content = BSL.toStrict $ T.encodeUtf8 username


checkToken :: AuthToken -> AuthDBM (Maybe Username)
checkToken (AuthToken username _ id_) = do
  AuthDB_{..} <- ask >>= \(AuthDB _ dbref) -> tryIO $ readIORef dbref
  if id_ `M.member` tokenmap
    then return $ Just username
    else return Nothing


saveDatabase :: AuthDBM ()
saveDatabase = do
  AuthDB path ref <- ask
  db <- liftIO $ readIORef ref
  tryIO (BS.writeFile path (BSL.toStrict $ encode db))


loadDatabase :: FilePath -> ExceptT AuthException IO AuthDB
loadDatabase path = do
  content <- tryIO (BSL.fromStrict `fmap` BS.readFile path)
  authDB <- either (throwError . ParseException) return (eitherDecode content)
  authDBRef <- liftIO $ newIORef authDB
  return $ AuthDB path authDBRef


hashPassword :: Password -> IO (Maybe PWHash)
hashPassword (Password pass) =
  (fmap PWHash) `fmap` BCrypt.hashPasswordUsingPolicy hashingPolicy (TS.encodeUtf8 pass)


tryIO :: (MonadError AuthException m, MonadIO m) => IO a -> m a
tryIO act = (liftIO $ try act) >>= either (throwError . IOException) return


-- randomString :: Int -> IO BS.ByteString
-- randomString i = BS.pack `fmap` sequence (take i $ repeat randomIO :: [IO Word8])


getTimeNearestSecond :: IO UTCTime
getTimeNearestSecond = getCurrentTime >>= \t -> return (t { utctDayTime = fromIntegral (round (utctDayTime t) :: Integer) })


-- data AuthDB_ = AuthDB_ { usermap :: M.Map Username PWHash
--                        , tokenmap :: S.Set AuthToken
--                        }

instance ToJSON AuthDB_ where
  toJSON (AuthDB_ usermap tokenmap grantmap) =
    object [ "users" .= M.toList usermap
           , "tokens" .= M.toList tokenmap
           , "grants" .= M.toList grantmap
           ]

instance FromJSON AuthDB_ where
  parseJSON (Object obj) =
    AuthDB_ <$> (M.fromList <$> obj .: "users")
            <*> (M.fromList <$> obj .: "tokens")
            <*> (M.fromList <$> obj .: "grants")
  parseJSON _ = mempty


instance ToJSON Username where
  toJSON (Username name) = toJSON name

instance FromJSON Username where
  parseJSON (String text) = pure $ Username text
  parseJSON _ = mempty

instance ToJSON PWHash where
  toJSON (PWHash bytes) = String $ TS.decodeUtf8 $ Base64.encode bytes

instance FromJSON PWHash where
  parseJSON (String text) = case Base64.decode $ TS.encodeUtf8 text of
    Left err -> fail err
    Right hash -> pure $ PWHash hash
  parseJSON _ = mempty

instance ToJSON AuthToken where
  toJSON (AuthToken username expiration uuid) =
    object [ "name" .= username
           , "expiration" .= expiration
           , "uid" .= uuid
           ]

instance FromJSON AuthToken where
  parseJSON (Object obj) =
    AuthToken <$> obj .: "name"
              <*> obj .: "expiration"
              <*> obj .: "uid"
  parseJSON _ = mempty

instance ToJSON Expiration where
  toJSON (Expiration expiration) = toJSON expiration

instance FromJSON Expiration where
  parseJSON text@(String _) = Expiration <$> parseJSON text
  parseJSON _ = mempty

instance ToJSON TokenId where
  toJSON (TokenId uuid) = String $ TS.pack $ show uuid

instance FromJSON TokenId where
  parseJSON (String uuid) = maybe mempty (pure . TokenId) $ UUID.fromString $ T.unpack $ T.fromStrict uuid
  parseJSON _ = mempty
