User.hs

module DarcsDen.State.User where

import Control.Monad.Trans
import Control.Monad (replicateM)
import Data.Digest.Pure.SHA (sha512, bytestringDigest)
import Data.Maybe (catMaybes, isJust)
import Data.Time (UTCTime, formatTime)
import Data.Word (Word8)
import Database.CouchDB
import System.Directory (createDirectoryIfMissing)
import System.Locale (defaultTimeLocale)
import System.Random
import Text.JSON
import qualified Data.ByteString.Lazy as LBS

import DarcsDen.State.Repository
import DarcsDen.State.Util
import DarcsDen.Settings


data User =
    User
        { uID :: Maybe Doc
        , uRev :: Maybe Rev
        , uName :: String
        , uPaS :: Maybe ([Word8], [Word8]) -- uPassword, and uSalt
        , uOAuthIDs :: [OAuthID]
        , uFullName :: String
        , uWebsite :: String
        , uEmail :: String
        , uKeys :: [String]
        , uJoined :: UTCTime
        }
    deriving (Eq, Show)

data OAuthID = Github String -- Github login name
             | Google String -- Google sub
    deriving (Eq, Show, Read)

uPassword :: User -> Maybe [Word8]
uPassword u = fmap fst (uPaS u)

uSalt :: User -> Maybe [Word8]
uSalt u = fmap snd (uPaS u)

uGithubLoginName :: User -> Maybe String
uGithubLoginName u = foldl f Nothing (uOAuthIDs u)
   where f :: Maybe String -> OAuthID -> Maybe String
         f _ (Github xs) = Just xs
         f a _ = a

uGoogleSub :: User -> Maybe String
uGoogleSub u = foldl f Nothing (uOAuthIDs u)
   where f :: Maybe String -> OAuthID -> Maybe String
         f _ (Google xs) = Just xs
         f a _ = a

instance JSON User where
    readJSON o = do
        id' <- getID o
        rev' <- getRev o
        name <- getAttr o "name"
        pas <- gPas
        gid <- fmap (fmap Github) (getAttrOr o "gid" Nothing)
        gsub <- fmap (fmap Google) (getAttrOr o "gsub" Nothing)
        fullName <- getAttrOr o "full_name" ""
        website <- getAttrOr o "website" ""
        email <- getAttrOr o "email" ""
        keys <- getAttrOr o "keys" []
        joined <- getTime o "joined"
        return User
            { uID = Just id'
            , uRev = Just rev'
            , uName = name
            , uPaS = pas
            , uOAuthIDs = catMaybes [gid, gsub]
            , uFullName = fullName
            , uWebsite = website
            , uEmail = email
            , uKeys = keys
            , uJoined = joined
            }
      where
        gPas = do
           v <- getAttrOr o "pas" Nothing
           if isJust v
            then return v
            else do
              p <- getAttrOr o "password" []
              s <- getAttrOr o "salt" []
              if null p || null s then return Nothing else return (Just (p,s))

    showJSON u = JSObject . toJSObject $
        [ ("name", showJSON (uName u))
        , ("pas", showJSON (uPaS u))
        , ("gid", showJSON (uGithubLoginName u))
        , ("gsub", showJSON (uGoogleSub u))
        , ("full_name", showJSON (uFullName u))
        , ("website", showJSON (uWebsite u))
        , ("email", showJSON (uEmail u))
        , ("keys", showJSON (uKeys u))
        , ("joined", showJSON (formatTime defaultTimeLocale "%F %T" (uJoined u)))
        ] ++ id' ++ rev'
      where
        id' =
            case uID u of
                Just id'' -> [("_id", showJSON (show id''))]
                Nothing -> []
        rev' =
            case uRev u of
                Just rev'' -> [("_rev", showJSON (show rev''))]
                Nothing -> []


userURL :: User -> String
userURL = (baseUrl ++) . uName

getUsers :: MonadIO m => m [User]
getUsers = do
    rs <- liftIO $ runDB $ queryView (db "users") (doc "users") (doc "by_name") []
    return $ map snd rs

-- getUsersWithRepos :: MonadIO m => m [User]
-- getUsersWithRepos = do
--     ids <- liftIO $ runDB (getAllDocIds (db "users"))
--     users <- mapM getUserByID ids
--     repos <- getRepositories
--     let userRepoCount u = \u -> (length $ filter ((u==).rOwner) repos)
--         userswithrepos = filter (\u -> userRepoCount u > 0) $ catMaybes users
--     return userswithrepos

getUser :: MonadIO m => String -> m (Maybe User)
getUser un = liftIO . runDB $
    getDocByView (db "users") (doc "users") (doc "by_name") un

getUserByID :: MonadIO m => Doc -> m (Maybe User)
getUserByID key = do
    res <- liftIO $ runDB (getDoc (db "users") key)
    case res of
         Just (_, _, r) -> return (Just r)
         Nothing -> return Nothing

getUserByEmail :: MonadIO m => String -> m (Maybe User)
getUserByEmail email = liftIO . runDB $
    getDocByView (db "users") (doc "users") (doc "by_email") email

getUserByGithub :: MonadIO m => String -> m (Maybe User)
getUserByGithub gid = liftIO . runDB $
   getDocByView (db "users") (doc "users") (doc "by_gid") (Just gid)

getUserByGoogle :: MonadIO m => String -> m (Maybe User)
getUserByGoogle gsub = liftIO . runDB $
   getDocByView (db "users") (doc "users") (doc "by_gsub") (Just gsub)

addUser :: MonadIO m => User -> m User
addUser u = do
    (id', rev') <- liftIO $ runDB (newDoc (db "users") u)
    return (u { uID = Just id', uRev = Just rev' })

updateUser :: MonadIO m => User -> m (Maybe User)
updateUser u =
    case (uID u, uRev u) of
        (Just id', Just rev') -> do
            update <- liftIO $ runDB (updateDoc (db "users") (id', rev') (u { uID = Nothing }))
            case update of
                Just (id'', rev'') ->
                    return $ Just u
                        { uID = Just id''
                        , uRev = Just rev''
                        }
                _ -> return Nothing
        _ -> return Nothing

deleteUser :: MonadIO m => User -> m Bool
deleteUser u =
    case (uID u, uRev u) of
        (Just id', Just rev') ->
            liftIO $ runDB (deleteDoc (db "users") (id', rev'))
        _ -> return False

salt :: Int -> IO [Word8]
salt num = do
    r <- replicateM num (randomRIO (0 :: Int, 255))
    return (map (\x -> fromIntegral x :: Word8) r)

hashPassword :: String -> [Word8] -> [Word8]
hashPassword p s
    = LBS.unpack
    . bytestringDigest
    . sha512
    . LBS.pack
    $ merge (map (fromIntegral . fromEnum) p) s
  where
    merge a b =
        concat (zipWith (\ x y -> [x, y]) a b) ++ remaining a b

    remaining a b
        | length a < length b = drop (length a) b
        | otherwise = drop (length b) a

checkPassword :: String -> User -> Bool
checkPassword p u = fmap (hashPassword p) (uSalt u) == uPassword u && isJust (uPaS u)

newUser :: MonadIO m => User -> m User
newUser u = do
    liftIO $ createDirectoryIfMissing True (userDir (uName u))
    addUser u

destroyUser :: MonadIO m => User -> m Bool
destroyUser u = do
    repos <- getUserRepositories (uName u)
    mapM_ destroyRepository repos
    deleteUser u

renameUser :: MonadIO m => String -> User -> m User
renameUser n u = do
    new <- newUser (u { uName = n })
    repos <- getUserRepositories n
    mapM_ (\r -> moveRepository (n, rName r) r) repos
    destroyUser u
    return new