{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}

module Main

where

import Control.Monad
import Data.Semigroup
import Data.Aeson.Encode.Pretty
import qualified Data.Aeson.Types as A

import qualified Data.Text as T (pack)
import qualified Data.ByteString.Lazy as LB (putStr)
import qualified Data.ByteString.UTF8 as BU (fromString)
import qualified Data.HashMap.Lazy as M

import System.Console.CmdArgs.Implicit

import Snap.Snaplet.Auth
import Snap.Snaplet.Auth.Backends.JsonFile
import Snap.Snaplet.Auth.Backends.SqliteSimple

import Database.SQLite.Simple
import Control.Concurrent.MVar
import Control.Exception (finally)


-- | Rank-2 type for action applicable to AuthManager and AuthUser.
type AuthUserAction = forall r. IAuthBackend r => r -> AuthUser -> IO ()


-- | Action for --read mode: show pretty JSON auth user entry.
readAction :: AuthUserAction
readAction _ au = LB.putStr $ encodePretty au


-- | Containers for which null predicate is defined.
class PossiblyNull a where
    null :: a

instance PossiblyNull [a] where
    null = []

instance PossiblyNull (Maybe a) where
    null = Nothing

instance PossiblyNull (M.HashMap k v) where
    null = M.empty

-- | Monoid under choosing non-null container.
--
-- We can map empty containers to Nothing and use standard monoid for
-- Nothing as well.
newtype NullMonoid a = NullMonoid { getContainer :: a }

instance (Eq a, PossiblyNull a) => Semigroup (NullMonoid a) where
    (NullMonoid x) <> (NullMonoid y) =
        NullMonoid (if x == Main.null then y else x)

instance (Eq a, PossiblyNull a) => Monoid (NullMonoid a) where
    mempty = NullMonoid Main.null
    mappend = (<>)

-- | Make 'AuthUserAction' which will replace user with the supplied
-- one. In case new user record does not set new password, roles or
-- meta, preserve old values.
makeUpdateAction :: AuthUser -> AuthUserAction
makeUpdateAction newUser amgr oldUser =
        let
            pick how = getContainer $ mconcat $
                       map (NullMonoid . how) [newUser, oldUser]
        in
          void $
          save amgr newUser{ userId = userId oldUser
                           , userPassword = pick userPassword
                           , userRoles = pick userRoles
                           , userMeta = pick userMeta
                           }


-- | Create new AuthUser object from data supplied from command line.
--
-- Has to be monadic due to 'setPassword' usage (hashing requires IO)
-- (in case of non-'Nothing' password).
buildAuthUser :: String             -- ^ User
              -> Maybe String       -- ^ Password
              -> [String]           -- ^ Roles
              -> [(String, String)] -- ^ List of key-value pairs of
                                    -- user metadata
              -> IO AuthUser
buildAuthUser l p rs mt =
    let
        login = T.pack l
        pass = BU.fromString <$> p
        roles = map (Role . BU.fromString) rs
        meta = M.fromList $
               map (\(k, v) -> (T.pack k, A.String $ T.pack v)) mt
        au' = defAuthUser{ userLogin = login
                         , userRoles = roles
                         , userMeta = meta
                         }
    in
        case pass of
          Nothing -> return au'
          Just pw -> setPassword au' pw


-- | Get user from backend by login and apply 'AuthUserAction' to it.
mgrOldUser :: IAuthBackend r => r
           -> String
           -> AuthUserAction
           -> IO ()
mgrOldUser amgr l f =
    let
        login = T.pack l
    in
      do
        au <- lookupByLogin amgr login
        case au of
          Just found -> f amgr found
          Nothing -> ioError $ userError $
                     l ++ ": user not found"


-- | Possible modes of operation.
data OpMode = Create | Read | Modify | Delete
              deriving (Show, Data, Typeable)


-- | user backend
data Backend = Json | Sqlite
              deriving (Show, Data, Typeable)


-- | Default instance for CmdArg.
instance Default OpMode where
    def = Read

instance Default Backend where
    def = Json



-- | Holds all options passed from command-line.
data Options = Options
    { mode     :: OpMode
    , user     :: Maybe String
    , password :: Maybe String
    , backend  :: Backend
    , file     :: FilePath
    , role     :: [String]
    , key      :: [String]
    , value    :: [String]
    }
    deriving (Show, Data, Typeable)


modifyHelp :: String
modifyHelp = "Modify password or replace roles and meta of existing user. " ++
             "If any of -p/-r/-k,-v flags is not set, previous value " ++
             "of that flag is preserved for account"


main :: IO ()
main =
    let
        sample = Options
                 { mode =
                   enum [ Read &= help "Read existing user"
                        , Create &= help "Create new user"
                        , Modify &= help modifyHelp
                        , Delete &= help "Delete user"] &= groupname "Mode"
                 , user = def &= help "User login" &= groupname "Other flags"
                 , password = def
                 , role = def &= name "o"
                   &= help "User role. May be specified multiple times"
                 , key = def &= name "k"
                   &= help "User meta key. Must be followed by value option"
                 , value = def &= name "v"
                   &= help "User meta value."
                 , backend =
                     enum [ Json &= help "Use the Json file backend"
                          , Sqlite &= help "Use the Sqlite file backend"
                          ] &= groupname "User database backend"
                 , file = "users.json" &= typFile
                   &= help "Path to database file"
                 }
                 &= program "snap-auth-cli"
    in do
      -- RecordWildCards
      opts@Options{..} <- cmdArgs sample
      case backend of
        Json ->  do
          amgr <- mkJsonAuthMgr file
          withAuthMgr opts amgr
        Sqlite -> do
          conn <- open file
          mv <- newMVar conn
          let amgr = mkSqliteAuthMgr "snap_auth_user" mv
          withAuthMgr opts amgr `finally` close conn


withAuthMgr :: IAuthBackend r => Options -> r -> IO ()
withAuthMgr Options{..} amgr =
  case (mode, user, password) of
        (_, Nothing, _) -> ioError $ userError "No user selected"
        (Read, Just l, _) -> mgrOldUser amgr l readAction
        (Delete, Just l, _) -> mgrOldUser amgr l destroy
        -- Require password for new users
        (Create, _, Nothing) -> ioError $ userError "No password set"
        (_, Just l, pw) ->
            do
                au <- buildAuthUser l pw role (zip key value)
                case mode of
                  Modify -> void $ mgrOldUser amgr l (makeUpdateAction au)
                  Create -> void $ save amgr au
                  _      -> error "Incompatible mode and options"