{-# LANGUAGE DeriveDataTypeable
           , FlexibleContexts
           , FlexibleInstances
           , MultiParamTypeClasses
           , TemplateHaskell
           , TypeFamilies
           #-}

{- WARNING: This code contains a security vulnerability.  Do not use this
 - code in a production environment!
 -}

import           Codec.Utils                (listToOctets)
import           Control.Concurrent         (MVar)
import           Control.Monad.Reader
import           Control.Monad.State
import           Data.Char                  (ord)
import           Data.Data                  (Data)
import qualified Data.Digest.SHA512         as SHA512
import qualified Data.Map                   as M
import           Data.Typeable              (Typeable)
import           Data.Word                  (Word8)
import           Happstack.State
import           Happstack.State.ClockTime
import           System.IO                  (hFlush, stdout)
import           System.Random              (Random, randomR, random)
import           System.Time                (ClockTime)

{- For some reason, Word8 isn't by default an instance of Random, but
 - that's easy enough to fix.
 -}
instance Random Word8 where
    randomR (lo, hi) rng = let (val, rng') = randomR (fromIntegral lo, fromIntegral hi) rng
                               val :: Int
                           in  (fromIntegral val, rng')
    random rng = randomR (minBound, maxBound) rng

{- | A hashed version of a user's password.  Passwords are given a unique
 -   random salt and are strengthened through repeated applications of the
 -   underlying hash algorithm.
 -}
data PasswordHash = PasswordHash { pwHash :: [Word8]
                                 , pwSalt :: [Word8]
                                 }
    deriving (Typeable, Data)

instance Version PasswordHash
$(deriveSerialize ''PasswordHash)

{- | Compute the salted, strengthened hash of a password.
 -}
hashPassword :: [Word8] -> String -> [Word8]
hashPassword salt password =
        let passBytes = listToOctets $ map ord password
        in  (iterate step passBytes) !! iterationCount
    where iterationCount = 100
          step chain = SHA512.hash (chain ++ salt)

{- | Generate new, random salt value, using the monad's RNG functions.
 -   We don't care how cryptographically strong the salt is, just as
 -   long as it's different from the other salts.
 -}
newSalt :: AnyEv [Word8]
newSalt = sequence $ take saltLength $ repeat getRandom
    where saltLength = 10

{- | Information about a registered user.
 -}
data UserInfo = UserInfo { usPassword :: PasswordHash
                         , usJoined   :: ClockTime
                         }
    deriving (Typeable, Data)

instance Version UserInfo
$(deriveSerialize ''UserInfo)

{- | Directory of all registered users, keyed by user name.
 -}
newtype UserDirectory = UserDirectory (M.Map String UserInfo)
    deriving (Typeable, Data)

instance Version UserDirectory
$(deriveSerialize ''UserDirectory)

instance Component UserDirectory where
    type Dependencies UserDirectory = End
    initialValue = UserDirectory M.empty

{- | getEventClockTime returns a malformed value, treating the first
 -   component of TOD as milliseconds instead of seconds.  This function
 -   fixes that.
 -
 -   See http://code.google.com/p/happstack/issues/detail?id=86
 -}
fixEventClockTime :: ClockTime -> ClockTime
fixEventClockTime (TOD milli pico) =
    let (trueSec, trueMilli) = milli `divMod` 1000
        truePico = trueMilli * 1000000000 + pico
    in  TOD trueSec truePico

{- | Add a new user to the directory, reporting failure if a user by
 -   that name already exists.
 -}
addUser :: String -> String -> Update UserDirectory Bool
addUser name pass = do
    UserDirectory dir <- get
    if M.member name dir
        then return False
        else do salt <- newSalt
                now <- liftM fixEventClockTime getEventClockTime
                let passwordHash = PasswordHash (hashPassword salt pass) salt
                let userInfo = UserInfo passwordHash now
                put $ UserDirectory $ M.insert name userInfo dir
                return True

{- | Check if a user's password matches what's in his or her profile.
 -}
checkPassword :: String -> String -> Query UserDirectory Bool
checkPassword name pass = do
    UserDirectory dir <- ask
    case M.lookup name dir of
        Nothing       -> return False
        Just userInfo -> let PasswordHash hash salt = usPassword userInfo
                         in  return $ hash == hashPassword salt pass

{- | Get a list of all users and when they signed up.
 -}
listUsers :: Query UserDirectory [(String, ClockTime)]
listUsers = do
    UserDirectory dir <- ask
    return $ M.toList $ M.map usJoined dir

$(mkMethods ''UserDirectory ['addUser, 'checkPassword, 'listUsers])

-- Everything below here implements the command interpreter for testing. --

{- | Interactive command loop for manipulating the persistent state.
 -}
commandLoop :: MVar TxControl -> IO ()
commandLoop state = do
        putStr "> "
        hFlush stdout
        command <- liftM words getLine
        processCommand state command
    where processCommand state ["list"] = do
                    people <- query ListUsers
                    mapM_ (putStrLn . showUser) people
                    commandLoop state
          processCommand state ["add", user, pass] = do
                    success <- update $ AddUser user pass
                    putStrLn $ if success then "User added" else "User already exists"
                    commandLoop state
          processCommand state ["login", user, pass] = do
                    success <- query $ CheckPassword user pass
                    putStrLn $ if success then "Success" else "Bad account or password"
                    commandLoop state
          processCommand state ["checkpoint"] = do
                    createCheckpoint state
                    commandLoop state
          processCommand _     ["quit"] = return ()
          processCommand state _        = do
                    putStrLn "Unrecognized command"
                    commandLoop state
          showUser (name, joined) = name ++ " (joined " ++ show joined ++ ")"

{- | Dataless Proxy object used by Happstack.State to figure out the
 -   type of data being kept in the MACID store.
 -}
macidProxy :: Proxy UserDirectory
macidProxy = Proxy

{- | Launch the interactive command loop.
 -}
main :: IO ()
main = startSystemState macidProxy >>= commandLoop