User.hs

{-# LANGUAGE OverloadedStrings #-}
module DarcsDen.Handler.User where

import Control.Monad (when, replicateM)
import Control.Monad.Trans
import qualified Data.ByteString.Char8 as BS
import Data.Char (toLower)
import Data.Function (on)
import Data.Time (getCurrentTime)
import Data.Map ((!))
import Data.Maybe (fromJust, isJust)
import Data.List (intercalate, nub, nubBy)
import Data.Text (pack)
import qualified Data.Text.Lazy as DTL
import System.Random (randomRIO)
import Snap.Core
import Network.HTTP.Conduit (queryString)
import Network.Mail.Mime(simpleMail, Address(..), renderSendMail)

import DarcsDen.Settings
import DarcsDen.State.ForgotPassword
import DarcsDen.State.Repository
import DarcsDen.State.Session
import DarcsDen.State.User
import DarcsDen.State.Util
import DarcsDen.Util (fromBS, toUrl)
import DarcsDen.Validate
import DarcsDen.WebUtils
import DarcsDen.Github.Paths
import DarcsDen.Github.Util
import DarcsDen.Github.Handler
import DarcsDen.Google.Paths
import DarcsDen.Google.Util
import DarcsDen.Google.Handler
import qualified DarcsDen.Pages.User as Page


user :: Page
user s = do
    mname <- getParam "user"
    when (mname == Nothing) (errorPage "Username not specified.")

    muser <- getUser . fromBS . fromJust $ mname
    case muser of
        Nothing -> notFound
        Just u -> do
            let getrepos | sUser s == Just (uName u) = getOwnerRepositories
                         | otherwise                 = getUserRepositories
            rs <- getrepos (uName u)
            doPage (Page.user u rs) s

register :: Page
register s = doPage (Page.register []) s

githubLogin :: Page
githubLogin s = do
    cid <- getGId
    random <- liftIO $ replicateM 50 (randomRIO ('a', 'z'))
    let options = [("client_id", cid),
                   ("redirect_uri", baseUrl++"login/github/response"),
                   ("scope", "user,user:email"),
                   ("state", random)]
    setOAuthReg (Just (Left random)) s
    redirectTo (BS.unpack $ toUrl $ githubAccessRequest { queryString = BS.pack $ intercalate "&" (map (\(x,y) -> x ++ "=" ++ y) options) } )

githubLoginResponse :: Page
githubLoginResponse s = validate
    [ predicate "state" ((sOAuthReg s ==). Just . Left) "state did not match!"
    ]
    (\(OK _) -> do
         access_token <- getAccessToken
         login' <- getLoginID access_token
         u <- getUserByGithub login'
         case u of
             Nothing -> do
                email <- getEmailID access_token
                keys <- getKeys access_token
                setOAuthReg (Just (Right (Github login'))) s
                message "There is no account with this github credentials, creating new account" s
                Just s' <- getSession (sID s)
                doPage (Page.register [("name", login'), ("email", email), ("keys", unlines keys), ("oauth", "yes")]) s'
             Just r -> do
                setUser (Just $ uName r) s
                success "Logged in!" s
                redirectTo (baseUrl ++ uName r))
    (\(Invalid failed) -> 
        notify Warning s failed
            >>= doPage (Page.login []))

googleLogin :: Page
googleLogin s = do
   cid <- getGoogleClientId
   random <- liftIO $ replicateM 50 (randomRIO ('a', 'z'))
   let options = [ ("client_id", cid)
                 , ("response_type", "code")
                 , ("scope", "openid email")
                 , ("redirect_uri", baseUrl++"login/google/response")
                 , ("state", random)
                 ]
   setOAuthReg (Just (Left random)) s
   redirectTo (BS.unpack $ toUrl $ googleAccessRequest { queryString = BS.pack $ intercalate "&" (map (\(x,y) -> x ++ "=" ++ y) options) } )

googleLoginResponse :: Page
googleLoginResponse s = validate
   [ predicate "state" ((sOAuthReg s ==). Just . Left) "state did not match!"
   ]
   (\(OK _) -> do
      (sub, email) <- getSubAndEmail "login"
      u <- getUserByGoogle sub
      case u of
         Nothing -> do
            setOAuthReg (Just (Right (Google sub))) s
            message "There is no account with this google credentials, creating new account" s
            Just s' <- getSession (sID s)
            doPage (Page.register [("email", email), ("oauth", "yes")]) s'
         Just r -> do
            setUser (Just $ uName r) s
            success "Logged in!" s
            redirectTo (baseUrl ++ uName r))
    (\(Invalid failed) -> 
        notify Warning s failed
            >>= doPage (Page.login []))


githubRegister :: Page
githubRegister s = do
      cid <- getGId
      random <- liftIO $ replicateM 50 (randomRIO ('a', 'z'))
      let options = [("client_id", cid),
                     ("redirect_uri", baseUrl++"register/github/response"),
                     ("scope", "user,user:email"),
                     ("state", random)]
      setOAuthReg (Just (Left random)) s
      redirectTo (BS.unpack $ toUrl $ githubAccessRequest { queryString = BS.pack $ intercalate "&" (map (\(x,y) -> x ++ "=" ++ y) options) } )

githubRegisterResponse :: Page
githubRegisterResponse s = validate
    [ predicate "state" ((sOAuthReg s ==). Just. Left) "state did not match!"
    ]
    (\(OK _) -> do
         access_token <- getAccessToken
         login' <- getLoginID access_token
         u <- getUserByGithub login'
         case u of
            Nothing -> do
               email <- getEmailID access_token
               keys <- getKeys access_token
               setOAuthReg (Just (Right (Github login'))) s
               doPage (Page.register [("name", login'), ("email", email), ("keys", unlines keys), ("oauth", "yes")]) s
            Just _ -> do
               warn "This github account is already matched with an account!" s
               redirectTo baseUrl)
    (\(Invalid failed) ->
        notify Warning s failed
            >> redirectTo baseUrl)

googleRegister :: Page
googleRegister s = do
   cid <- getGoogleClientId
   random <- liftIO $ replicateM 50 (randomRIO ('a', 'z'))
   let options = [ ("client_id", cid)
                 , ("response_type", "code")
                 , ("scope", "openid email")
                 , ("redirect_uri", baseUrl++"register/google/response")
                 , ("state", random)
                 ]
   setOAuthReg (Just (Left random)) s
   redirectTo (BS.unpack $ toUrl $ googleAccessRequest { queryString = BS.pack $ intercalate "&" (map (\(x,y) -> x ++ "=" ++ y) options) } )

googleRegisterResponse :: Page
googleRegisterResponse s = validate
    [ predicate "state" ((sOAuthReg s ==). Just. Left) "state did not match!"
    ]
    (\(OK _) -> do
         (sub, email) <- getSubAndEmail "register"
         u <- getUserByGoogle sub
         case u of
            Nothing -> do
               setOAuthReg (Just (Right (Google sub))) s
               doPage (Page.register [("email", email), ("oauth", "yes")]) s
            Just _ -> do
               warn "This google account is already matched with an account!" s
               redirectTo baseUrl)
    (\(Invalid failed) ->
        notify Warning s failed
            >> redirectTo baseUrl)

doRegister :: Page
doRegister s = validate
    [ iff (nonEmpty "name")
          (\(OK r) -> io "name is already in use" $ do
              u <- getUser (r ! "name")
              return (u == Nothing))
    , predicate "name" isSane
        "contain only alphanumeric characters, underscores, and hyphens"
    , nonEmpty "email"
    , iff (nonEmpty "password1" `And` nonEmpty "password2")
          (const $ equal "password1" "password2") `Or` predicate "password1" (const usingOAuth) ""
    , predicate "email" (const True) "be a valid email"
    , Predicate "security_question" ((=="darcs").map toLower) "be answered correctly" `Or` predicate "security_question" (const usingOAuth) ""
    ]
    (\(OK r) -> do
       now <- liftIO getCurrentTime
       slt <- liftIO (salt 32)
       keys <- input "keys" ""
       new <- newUser
                  User { uID = Nothing
                       , uRev = Nothing
                       , uName = r ! "name"
                       , uPaS = fmap (\p -> (hashPassword p slt, slt)) (let v = r ! "password1" in if null v then Nothing else Just v)
                       , uOAuthIDs = oid
                       , uFullName = ""
                       , uWebsite = ""
                       , uEmail = r ! "email"
                       , uKeys = lines keys
                       , uJoined = now
                       }

       setUser (Just (uName new)) s
       success "You have been successfully registered and logged in." s
       redirectTo (baseUrl ++ (r ! "name")))
    (\(Invalid failed) -> do
        is <- getInputs
        notify Warning s failed
            >>= doPage (Page.register is))
    where sor = sOAuthReg s
          (oid, usingOAuth) = case sor of
                   Just (Right oid') -> ([oid'], True)
                   _ -> ([], False)

login :: Page
login s = doPage (Page.login []) s

doLogin :: Page
doLogin s = validate
    [ iff (nonEmpty "name" `And` nonEmpty "password") $ \(OK r) ->
          io "invalid username or password" $ do
          c <- getUser (r ! "name")
          case c of
              Nothing -> return False
              Just u -> return (checkPassword (r ! "password") u)
    ]
    (\(OK r) -> do
        setUser (Just $ r ! "name") s
        success "Logged in!" s
        redirectTo (baseUrl ++ (r ! "name")))
    (\(Invalid failed) -> do
        is <- getInputs
        notify Warning s failed
            >>= doPage (Page.login is))

logout :: Page
logout s = do
    setUser Nothing s
    success "Logged out." s
    redirectTo baseUrl

settings :: Page
settings s@(Session { sUser = Nothing }) = do
    warn "You must be logged in to change your settings." s
    redirectTo (baseUrl ++ "login")
settings s@(Session { sUser = Just n }) = validate
    [ io "you do not exist" $ fmap (/= Nothing) (getUser n)
    ]
    (\(OK _) -> do
       Just u <- getUser n
       doPage (Page.settings u) s)
    (\(Invalid f) -> notify Warning s f >> redirectTo baseUrl)

doSettings :: Page
doSettings s@(Session { sUser = Nothing }) = do
    warn "You must be logged in to change your settings." s
    redirectTo (baseUrl ++ "login")
doSettings s@(Session { sUser = Just n }) = validate
    [ io "you do not exist" $ fmap (/= Nothing) (getUser n)
    , onlyIf (nonEmpty "password1") $
        And (nonEmpty "password2" `And` equal "password1" "password2") $
            onlyIf (io "" $ do
                      Just u <- getUser n
                      return (isJust.uPaS $ u)) $
                iff (nonEmpty "password") $ \(OK is) -> io "password incorrect" $ do
                    Just u <- getUser n
                    return (checkPassword (is ! "password") u)
    ]
    (\(OK _) -> do
        Just u <- getUser n

        fullName <- input "full_name" (uFullName u)
        website <- input "website" (uWebsite u)
        keys <- input "keys" (unlines (uKeys u))

        oldp <- input "password" ""
        npass1 <- input "password1" ""
        npass2 <- input "password2" ""
        slt <- liftIO (salt 32)
        let npass
                | not ((null oldp && isJust (uPaS u)) || null npass1 || null npass2) && npass1 == npass2 =
                    Just (hashPassword npass1 slt, slt)
                | otherwise =
                    uPaS u

        updateUser u
            { uFullName = fullName
            , uWebsite = website
            , uKeys = lines keys
            , uPaS = npass
            }

        success "Settings updated." s

        redirectTo (baseUrl ++ "settings"))
    (\(Invalid f) -> notify Warning s f >> redirectTo (baseUrl ++ "settings"))

syncWithGithub :: Page
syncWithGithub s@(Session { sUser = Nothing }) = do
   warn "You must be logged in." s
   redirectTo (baseUrl ++ "login")
syncWithGithub s@(Session { sUser = Just n }) = validate
    [ io "you do not exist" $ fmap (/= Nothing) (getUser n)
    ]
    (\(OK _) -> do
        cid <- getGId
        random <- liftIO $ replicateM 50 (randomRIO ('a', 'z'))
        let options = [("client_id", cid),
                       ("redirect_uri", baseUrl++"sync/github/response"),
                       ("scope", "user"),
                       ("state", random)]
        setOAuthReg (Just (Left random)) s
        redirectTo (BS.unpack $ toUrl $ githubAccessRequest { queryString = BS.pack $ intercalate "&" (map (\(x,y) -> x ++ "=" ++ y) options) } ))
    (\(Invalid f) -> notify Warning s f >> redirectTo baseUrl)

syncWithGithubResponse :: Page
syncWithGithubResponse s@(Session { sUser = Nothing }) = do
   warn "You must be logged in." s
   redirectTo (baseUrl ++ "login")
syncWithGithubResponse s@(Session { sUser = Just n }) = validate
    [ io "you do not exist" $ fmap (/= Nothing) (getUser n)
    , predicate "state" ((sOAuthReg s ==). Just . Left) "state did not match!"
    ]
    (\(OK _) -> do
         Just u' <- getUser n
         access_token <- getAccessToken
         login' <- getLoginID access_token
         u <- getUserByGithub login'
         case u of
            Just x | uName x /= uName u' -> do
               warn "This github account is already linked to another account!" s
               setOAuthReg Nothing s
               redirectTo (baseUrl ++ "settings")
            _ -> do
               keys <- getKeys access_token
               updateUser u'
                  { uOAuthIDs = nub (Github login':uOAuthIDs u')
                  , uKeys = nubBy (on (==) cp) (keys ++ uKeys u')
                  }
               success "Account Synced." s
               setOAuthReg Nothing s
               redirectTo (baseUrl ++ "settings"))
    (\(Invalid f) -> notify Warning s f >> redirectTo baseUrl)
        where cp = take 2 . words

syncWithGoogle :: Page
syncWithGoogle s@(Session { sUser = Nothing }) = do
   warn "You must be logged in." s
   redirectTo (baseUrl ++ "login")
syncWithGoogle s@(Session { sUser = Just n }) = validate
   [ io "you do not exist" $ fmap (/= Nothing) (getUser n)
   ]
   (\(OK _) -> do
      cid <- getGoogleClientId
      random <- liftIO $ replicateM 50 (randomRIO ('a', 'z'))
      let options = [ ("client_id", cid)
                    , ("response_type", "code")
                    , ("scope", "openid email")
                    , ("redirect_uri", baseUrl++"sync/google/response")
                    , ("state", random)
                    ]
      setOAuthReg (Just (Left random)) s
      redirectTo (BS.unpack $ toUrl $ googleAccessRequest { queryString = BS.pack $ intercalate "&" (map (\(x,y) -> x ++ "=" ++ y) options) } ))
    (\(Invalid f) -> notify Warning s f >> redirectTo baseUrl)

syncWithGoogleResponse :: Page
syncWithGoogleResponse s@(Session { sUser = Nothing }) = do
   warn "You must be logged in." s
   redirectTo (baseUrl ++ "login")
syncWithGoogleResponse s@(Session { sUser = Just n }) = validate
    [ io "you do not exist" $ fmap (/= Nothing) (getUser n)
    , predicate "state" ((sOAuthReg s ==). Just . Left) "state did not match!"
    ]
    (\(OK _) -> do
         Just u' <- getUser n
         (sub, _) <- getSubAndEmail "sync"
         u <- getUserByGoogle sub
         case u of
            Just x | uName x /= uName u' -> do
               warn "This google account is already linked to another account!" s
               setOAuthReg Nothing s
               redirectTo (baseUrl ++ "settings")
            _ -> do
               updateUser u'
                  { uOAuthIDs = nub (Google sub:uOAuthIDs u')
                  }
               success "Account Synced." s
               setOAuthReg Nothing s
               redirectTo (baseUrl ++ "settings"))
    (\(Invalid f) -> notify Warning s f >> redirectTo baseUrl)

forgotPassword :: Page
forgotPassword s = doPage (Page.forgotPassword []) s

forgotPasswordResponse :: Page
forgotPasswordResponse s = validate
   [ iff (nonEmpty "username") (\(OK r) -> io "User does not exist." (fmap isJust (getUser (r ! "username")))) ]
   (\(OK r) -> do
      Just u <- getUser (r ! "username")
      str <- createFpForUser u
      let v = baseUrl ++ "recovery?fpid=" ++ str
      liftIO $ simpleMail
         (Address (Just . pack $ uName u) (pack $ uEmail u))
         (Address (Just . pack $ sendName) (pack $ sendEmail))
         (pack $ "Reset Password")
         DTL.empty
         (DTL.pack $ "<a href="++v++">reset password</a>")
         []
       >>= renderSendMail
      success "Mail sent to user's email account." s
      redirectTo baseUrl)
   (\(Invalid f) -> notify Warning s f >> redirectTo (baseUrl ++ "forgotpassword"))

resetPassword :: Page
resetPassword s = validate
   [ iff (nonEmpty "fpid") (\(OK r) -> io "invalid or outdated fpid" (fmap isJust (getUserFromFp (r ! "fpid"))))
   ]
   (\(OK r) -> do
      Just u <- getUserFromFp (r ! "fpid")
      s' <- setUser (Just $ uName u) s
      deleteFp (r!"fpid")
      doPage (Page.resetPassword []) s'
   )
   (\(Invalid f) -> notify Warning s f >> redirectTo baseUrl)

resetPasswordResponse :: Page
resetPasswordResponse s@(Session { sUser = Nothing }) = do
   warn "You must be logged in." s
   redirectTo baseUrl
resetPasswordResponse s@(Session { sUser = Just n }) = validate
   [  nonEmpty "password1" 
   ,  equal "password1" "password2"
   ]
   (\(OK r) -> do
     Just u <- getUser n
     slt <- liftIO (salt 32)
     let npass = Just (hashPassword (r!"password1") slt, slt)
     updateUser u
        { uPaS = npass
        }
     success "Password Changed." s
     redirectTo baseUrl)
    (\(Invalid failed) -> do
        notify Warning s failed
            >>= doPage (Page.resetPassword []))