{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies  #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Web.Users.Persistent (LoginId, Persistent(..)) where

import Web.Users.Types

import Control.Applicative ((<$>), (<|>))
import Control.Monad
import Control.Monad.Reader
#if MIN_VERSION_mtl(2,2,0)
import Control.Monad.Except
#else
import Control.Monad.Error
#endif
import Data.Aeson
import Data.Typeable
import Data.Time.Clock
import Database.Persist
import Database.Persist.Sql
import Database.Persist.TH
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Login
    createdAt UTCTime
    username T.Text
    email T.Text
    password T.Text
    active Bool
    more BSC.ByteString
    UniqueUsername username
    UniqueEmail email
    deriving Show
    deriving Eq
    deriving Typeable
LoginToken
    token T.Text
    tokenType T.Text
    createdAt UTCTime
    validUntil UTCTime
    owner LoginId
    UniqueToken token
    UniqueTypedToken token tokenType
    deriving Show
    deriving Eq
    deriving Typeable
|]

#if MIN_VERSION_base(4,7,0)
deriving instance Typeable Key
#else
deriving instance Typeable1 Key
#endif

#if MIN_VERSION_mtl(2,2,0)
type ErrorT = ExceptT
runErrorT :: ErrorT e m a -> m (Either e a)
runErrorT = runExceptT
#else
-- a hack... :-(
instance Error UpdateUserError where
    noMsg = error "Calling fail not supported"
    strMsg = error "Calling fail not supported"
#endif

packLogin :: (Monad m, ToJSON a) => User a -> m (UTCTime -> Login)
packLogin usr =
    do p <-
           case u_password usr of
             PasswordHash p -> return p
             _ -> fail "Invalid password! Not hashed!"
       return $ \t ->
           Login
           { loginUsername = u_name usr
           , loginEmail = u_email usr
           , loginPassword = p
           , loginActive = u_active usr
           , loginMore = BSL.toStrict $ encode (u_more usr)
           , loginCreatedAt = t
           }

unpackLogin :: (FromJSON a, Monad m) => Login -> m (User a)
unpackLogin l =
    do up <- unpackLogin' l
       return $ up { u_password = PasswordHidden }

unpackLogin' :: (FromJSON a, Monad m) => Login -> m (User a)
unpackLogin' l =
    do more <-
           case eitherDecodeStrict' (loginMore l) of
             Left err -> fail err
             Right val -> return val
       return $
            User
            { u_name = loginUsername l
            , u_email = loginEmail l
            , u_password = PasswordHash (loginPassword l)
            , u_active = loginActive l
            , u_more = more
            }

mkTuple :: (FromJSON a, Monad m) => Entity Login -> m (LoginId, User a)
mkTuple entity =
    do user <- unpackLogin (entityVal entity)
       return (entityKey entity, user)

newtype Persistent = Persistent { runPersistent :: forall a. SqlPersistT IO a -> IO a }

instance UserStorageBackend Persistent where
    type UserId Persistent = LoginId
    initUserBackend conn =
        runPersistent conn $ runMigration migrateAll
    destroyUserBackend conn =
        runPersistent conn $
        do _ <- rawExecute "DROP TABLE IF EXISTS \"login\";" []
           _ <- rawExecute "DROP TABLE IF EXISTS \"login_token\";" []
           return ()
    housekeepBackend conn =
        do now <- getCurrentTime
           runPersistent conn $ deleteWhere [LoginTokenValidUntil <=. now]
    getUserIdByName conn userOrEmail =
        runPersistent conn $
        do mUserA <- getBy (UniqueUsername userOrEmail)
           mUserB <- getBy (UniqueEmail userOrEmail)
           return $ fmap entityKey (mUserA <|> mUserB)
    getUserById conn loginId =
        runPersistent conn $
        do mUser <- get loginId
           return $ join $ fmap unpackLogin mUser
    listUsers conn mLimit =
        runPersistent conn $
        do xs <-
               case mLimit of
                 Nothing -> selectList [] []
                 Just (start, lim) -> selectList [] [OffsetBy (fromIntegral start), LimitTo (fromIntegral lim)]
           mapM mkTuple xs
    countUsers conn =
        liftM fromIntegral $
        runPersistent conn $ count ([] :: [Filter Login])
    createUser conn l =
        case packLogin l of
          Nothing -> return $ Left InvalidPassword
          Just mkUser ->
              do now <- getCurrentTime
                 let usr = mkUser now
                 runPersistent conn $
                   do mFst <- selectFirst ([LoginUsername ==. loginUsername usr] ||. [LoginEmail ==. loginEmail usr]) []
                      case mFst of
                        Just _ -> return $ Left UsernameOrEmailAlreadyTaken
                        Nothing -> Right <$> insert usr
    updateUser conn userId updateFun =
        do mUser <- getUserById conn userId
           case mUser of
             Nothing ->
                 return $ Left UserDoesntExit
             Just origUser ->
                 runErrorT $
                 do let newUser = updateFun origUser
                    when (u_name newUser /= u_name origUser) $
                         do counter <- liftIO $ runPersistent conn $ count [LoginUsername ==. u_name newUser]
                            when (counter /= 0) $ throwError UsernameOrEmailAlreadyExists
                    when (u_email newUser /= u_email origUser) $
                         do counter <- liftIO $ runPersistent conn $ count [LoginEmail ==. u_email newUser]
                            when (counter /= 0) $ throwError UsernameOrEmailAlreadyExists
                    liftIO $ runPersistent conn $
                       do update userId [ LoginUsername =. u_name newUser, LoginEmail =. u_email newUser, LoginActive =. u_active newUser
                                        , LoginMore =. (BSL.toStrict $ encode $ u_more newUser) ]
                          case u_password newUser of
                            PasswordHash p -> update userId [ LoginPassword =. p ]
                            _ -> return ()
    deleteUser conn userId =
        runPersistent conn $ delete userId
    withAuthUser conn userOrEmail authFn action =
        runPersistent conn $
        do mFst <- selectFirst ([LoginUsername ==. userOrEmail] ||. [LoginEmail ==. userOrEmail]) []
           case mFst of
             Nothing -> return Nothing
             Just login ->
                 do user <- unpackLogin' (entityVal login)
                    if authFn user
                    then liftIO $ Just <$> action (entityKey login)
                    else return Nothing
    authUser conn userOrEmail pwd sessionTtl =
        withAuthUser conn userOrEmail (\(user :: User Value) -> verifyPassword pwd $ u_password user) $ \userId ->
            SessionId <$> createToken conn "session" userId sessionTtl
    verifySession conn (SessionId sessionId) extendTime =
        do mUser <- getTokenOwner conn "session" sessionId
           case mUser of
             Nothing -> return Nothing
             Just userId ->
                 do extendToken conn "session" sessionId extendTime
                    return (Just userId)
    destroySession conn (SessionId sessionId) = deleteToken conn "session" sessionId
    requestPasswordReset conn userId timeToLive =
        do token <- createToken conn "password_reset" userId timeToLive
           return $ PasswordResetToken token
    requestActivationToken conn userId timeToLive =
        do token <- createToken conn "activation" userId timeToLive
           return $ ActivationToken token
    activateUser conn (ActivationToken token) =
        do mUser <- getTokenOwner conn "activation" token
           case mUser of
             Nothing ->
                 return $ Left TokenInvalid
             Just userId ->
                 do _ <-
                        updateUser conn userId $ \(user :: User Value) -> user { u_active = True }
                    deleteToken conn "activation" token
                    return $ Right ()
    verifyPasswordResetToken conn (PasswordResetToken token) =
        do mUser <- getTokenOwner conn "password_reset" token
           case mUser of
             Nothing -> return Nothing
             Just userId -> getUserById conn userId
    applyNewPassword conn (PasswordResetToken token) password =
        do mUser <- getTokenOwner conn "password_reset" token
           case mUser of
             Nothing ->
                 return $ Left TokenInvalid
             Just userId ->
                 do _ <-
                        updateUser conn userId $ \(user :: User Value) -> user { u_password = password }
                    deleteToken conn "password_reset" token
                    return $ Right ()

createToken :: Persistent -> String -> LoginId -> NominalDiffTime -> IO T.Text
createToken conn tokenType userId timeToLive =
    runPersistent conn $
    do tok <- liftM (T.pack . UUID.toString) $ liftIO $ UUID.nextRandom
       now <- liftIO $ getCurrentTime
       _ <- insert $ LoginToken tok (T.pack tokenType) now (timeToLive `addUTCTime` now) userId
       return tok

deleteToken :: Persistent -> String -> T.Text -> IO ()
deleteToken conn tokenType token =
    runPersistent conn $
    case UUID.fromString (T.unpack token) of
      Nothing -> return ()
      Just _ ->
          do deleteBy (UniqueTypedToken token (T.pack tokenType))
             return ()

extendToken :: Persistent -> String -> T.Text -> NominalDiffTime -> IO ()
extendToken conn tokenType token timeToLive =
    runPersistent conn $
    case UUID.fromString (T.unpack token) of
      Nothing -> return ()
      Just _ ->
          do now <- liftIO $ getCurrentTime
             updateWhere [LoginTokenToken ==. token, LoginTokenTokenType ==. (T.pack tokenType)] [LoginTokenValidUntil =. (timeToLive `addUTCTime` now)]
             return ()

getTokenOwner :: Persistent -> String -> T.Text -> IO (Maybe LoginId)
getTokenOwner conn tokenType token =
    runPersistent conn $
    case UUID.fromString (T.unpack token) of
      Nothing -> return Nothing
      Just _ ->
          do now <- liftIO $ getCurrentTime
             m <- selectFirst [LoginTokenTokenType ==. T.pack tokenType, LoginTokenToken ==. token, LoginTokenValidUntil >. now] []
             return $ fmap (loginTokenOwner . entityVal) m