module RESTng.System.Authentication
   ( withAuthentication,
     afterSettingAuthUser,
     anyLoginHandler
   ) where


import Prelude hiding(span, div)
import Control.Monad.Trans (liftIO, lift)
import Control.Monad.Reader (ask)

import Network.HTTP.RedHandler.Session
import Text.CxML
import RESTng.RESTngMonad (RESTng, getAuthUser, withAuthUser)
import RESTng.RqHandlers
import RESTng.System.PersistableResource (find, select01)
import RESTng.Resources.User
import RESTng.Resources.UserModel (userProxy)


cookieName = "rnAuth"
          
-- example_credentials="webmaster:zrma4v" ; from http pocket ref example (note error in book - see online errata)
--encB64 s = B64.encode $ map (fromIntegral . ord) s
--decB64 s = map (chr . fromIntegral) $ B64.decode s

authenticateBasicHttp :: RequestContext -> RESTng (Maybe User)
authenticateBasicHttp rc = return Nothing

authenticateSession :: RequestContext -> RESTng (Maybe User)
authenticateSession rc = do maybeUserId <- liftIO $ getSessionedStateWithCookie cookieName rc
                            case maybeUserId of
                              Nothing -> return Nothing
                              Just uid -> find uid userProxy
--FIXME: do something if the user does not exist (find returns nothing).
-- It is possible if the user has been deleted recently.

authenticate :: RequestContext -> RESTng (Maybe User)
authenticate rc = do auth1 <- authenticateBasicHttp rc
                     case auth1 of
                       Nothing -> authenticateSession rc
                       _       -> return auth1


afterSettingAuthUser :: RqHandlerT RESTng a -> RqHandlerT RESTng a
afterSettingAuthUser han = do rc <- ask
                              authUsr <- lift (authenticate rc)
                              mapRqHandlerT (withAuthUser authUsr) han


-- If the authUser has not been set. and the credentials are ok, then this function set it.
-- After that, if the authentication is successful continue with the handler argument
--             otherwise continue with the login page (with the url for continuation encoded)
withAuthentication, withAuthentication' :: RqHandlerT RESTng RESTngResp -> RqHandlerT RESTng RESTngResp
withAuthentication = afterSettingAuthUser . withAuthentication'

withAuthentication' han = do authUsr <- lift getAuthUser
                             case authUsr of
                                    Nothing -> getLoginHandler'
                                    _ -> han


getLoginHandler :: Monad m => RqHandlerT m RESTngResp
getLoginHandler = ifGet $ withDocName "login" $ getLoginHandler'

getLoginHandler' :: Monad m => RqHandlerT m RESTngResp
getLoginHandler' = okCxML $ withCtx loginForm


loginForm :: RequestContext -> CxML a
loginForm rq
           = form!("method","post")!("action","/login.html") 
                /- [br, 
                    showField "username", 
                    showField "password", 
                    hideField "kurl" kurl,
                    button!("name","action")!("value","submit") /- [t "Submit"] ]
              where
                           showField :: String -> CxML a
                           showField s = concatCxML [span /- [t s], textfield s, br ]
                           hideField name val = span /- [hidden name val, br ]
                           kurl = if (docName rq /= "login")
                                     then completeURL rq
                                     else -- we should redirect the output only if specified in the query parameters, otherwise set kurl to ""
                                          case lookup "kurl" $ query rq of
                                             Nothing -> ""
                                             Just url -> url


postLoginHandler :: RqHandlerT RESTng RESTngResp
postLoginHandler = ifPost $ withDocName "login" $ withPostFields $ \pfs -> postLoginHandler' (map snd pfs)
                   where
                     postLoginHandler' (uname: pass: kurl: _ ) = processLogin uname pass kurl
                     postLoginHandler' _ = failedLoginHandler

processLogin :: String -> String -> String -> RqHandlerT RESTng RESTngResp
processLogin uname pass kurl =
                   do maybeUser <- lift $ select01 [("username", uname)] userProxy
                      case maybeUser of
                        Nothing -> failedLoginHandler
                        Just u -> if isValidPass u pass
                                    then succededLoginHandler (user_id u) kurl
                                    else failedLoginHandler
                   where
                     isValidPass u pass = passwd u == pass

failedLoginHandler :: Monad m => RqHandlerT m RESTngResp
failedLoginHandler = return $ okNonCxMLStrRsp "Login Failed"

succededLoginHandler :: Integer -> String -> RqHandlerT RESTng RESTngResp
succededLoginHandler uid k = do setCookieFunc <- liftIO $ newSessionedStateWithCookie cookieName uid
                                fmap setCookieFunc (maybeRedirectHandler k)
                                   where
                                     maybeRedirectHandler :: String -> RqHandlerT RESTng RESTngResp
                                     -- redirect or say hello
                                     maybeRedirectHandler [] = return $ okNonCxMLStrRsp "Welcome!"
                                     maybeRedirectHandler k = return $ redirectToRsp k


logoutHandler :: RqHandlerT RESTng RESTngResp
logoutHandler = withDocName "logout" $ processLogoutHandler


processLogoutHandler :: RqHandlerT RESTng RESTngResp
processLogoutHandler = do rqCtx <- ask
                          setCookieFunc <- liftIO $ deleteSessionedStateWithCookie cookieName rqCtx
                          fmap setCookieFunc (return $ okNonCxMLStrRsp "GoodBye")
-- should be just post? or a get, being transformed in a post like in the delete?
-- should remove the user from the ctx

anyLoginHandler = anyOf [getLoginHandler, postLoginHandler, logoutHandler]