import Quixotic.Api
import Quixotic.Api.Types
import Quixotic.Api.Users

import Quixotic.Snaplet
import Quixotic.Snaplet.Auth
import Quixotic.Snaplet.Users
import Quixotic.Snaplet.WorkLog

  addRoutes [ ("login", loginHandler (const ok)) 

  addRoutes [ ("login", requireLogin >> (redirect "/home")) 

{-# LANGUAGE NoImplicitPrelude #-}
module Api.Worklog (resource) where
import ClassyPrelude
import Control.Applicative ((<$>))
import Control.Concurrent.STM (atomically, modifyTVar, readTVar)
import Control.Monad.Error (throwError)
import Control.Monad.Reader (ReaderT, asks)
import Control.Monad.Trans (liftIO)
import Data.Set (Set)
import qualified Data.Foldable as F
import qualified Data.Set      as Set
import qualified Data.Text     as T
import Rest (Handler, ListHandler, Range (count, offset), Resource, Void, domainReason, mkInputHandler, mkListing, mkResourceReader, named, singleRead,
             withListing, xmlJsonE, xmlJsonI, xmlJsonO)
import qualified Rest.Resource as R
import ApiTypes (BlogApi, ServerData (..))
import Type.User (User)
import Type.UserInfo (UserInfo (..))
import Type.UserSignupError (UserSignupError (..))
import qualified Type.User     as User
import qualified Type.UserInfo as UserInfo
resource :: 

module Quixotic.Snaplet.Auth where
import ClassyPrelude 
import Control.Lens
import Control.Monad.State
import Data.ByteString (split)
import Data.Attoparsec.ByteString 
import qualified Data.ByteString.Base64 as B64
import Quixotic
import Quixotic.Database
import Quixotic.Snaplet
import Snap.Core
import Snap.Snaplet
import Snap.Snaplet.PostgresqlSimple
import qualified Snap.Snaplet.Auth as AU
type AuthHeader = (Text, ByteString)
authHeaderParser :: Parser AuthHeader
authHeaderParser = do
  let isBase64Char w = (w >= 47 && w <= 57 ) ||
                       (w >= 64 && w <= 90 ) ||
                       (w >= 97 && w <= 122) ||
                       (w == 43 || w == 61 )
  b64     <- string "Basic" *> takeWhile1 isBase64Char 
  decoded <- either fail pure $ B64.decode b64
  case split 58 decoded of
    (uname : pwd : []) -> pure $ (decodeUtf8 uname, pwd)
    _ -> fail "Could not unpack auth header into username and password components"
requireLogin :: Handler App App AU.AuthUser 
requireLogin = do
  req <- getRequest
  rawHeader    <- maybe throwChallenge pure $ getHeader "Authorization" req
  (uname, pwd) <- either (throwDenied . AU.AuthError) pure $ parseOnly authHeaderParser rawHeader 
  authResult   <- with auth $ AU.loginByUsername uname (AU.ClearText pwd) False
  either throwDenied pure authResult
requireUser :: Handler App App AU.AuthUser 
requireUser = do 
  currentUser <- with auth AU.currentUser
  maybe requireLogin pure currentUser
requireUserId :: Handler App App UserId
requireUserId = do
  QDB{..} <- view qdb <$> with qm get
  currentUser <- requireLogin
  qdbUser <- case UserName . AU.unUid <$> AU.userId currentUser of 
    Nothing -> snapError 403 "User is authenticated, but session lacks user identifier"
    Just n  -> liftPG . runReaderT $ findUserByUserName n
  case qdbUser of
    Nothing -> snapError 403 "Unable to retrieve user record for authenticated user" 
    Just u -> pure (u ^. userId)
requireProjectAccess :: UserId -> Handler App App ProjectId
requireProjectAccess uid = do
  pidMay <- getParam "projectId"
  case ProjectId <$> (readMay =<< fmap decodeUtf8 pidMay) of
    Nothing  -> snapError 403 "Value of parameter projectId could not be parsed to a valid value."
    Just pid -> error $ "FIXME: implement project access check - got pid " ++ " " ++ show uid ++ " " ++ show pid
throwChallenge :: MonadSnap m => m a
throwChallenge = do
    modifyResponse $ (setResponseStatus 401 "Unauthorized") . 
                     (setHeader "WWW-Authenticate" "Basic realm=quixotic")
    getResponse >>= finishWith
throwDenied :: MonadSnap m => AU.AuthFailure -> m a
throwDenied failure = do
    modifyResponse $ setResponseStatus 403 "Access Denied"
    writeText $ "Access Denied: " <> tshow failure
    getResponse >>= finishWith

{-# LANGUAGE TemplateHaskell, RecordWildCards #-}

{-# LANGUAGE TemplateHaskell #-}

module Quixotic.Api.Users 
  ( loginHandler
  , registerHandler

module Quixotic.Snaplet.Users 
  ( registerHandler

import Data.ByteString (split)
import Data.Attoparsec.ByteString 
import qualified Data.ByteString.Base64 as B64

import Quixotic.Api.Types

import Quixotic.Snaplet
import Quixotic.Snaplet.Auth

data AuthHeader = AuthHeader Text ByteString
authHeaderParser :: Parser AuthHeader
authHeaderParser = do
  let isBase64Char w = (w >= 47 && w <= 57 ) ||
                       (w >= 64 && w <= 90 ) ||
                       (w >= 97 && w <= 122) ||
                       (w == 43 || w == 61 )
  b64     <- string "Basic" *> takeWhile1 isBase64Char 
  decoded <- either fail pure $ B64.decode b64
  case split 58 decoded of
    (uname : pwd : []) -> pure $ AuthHeader (decodeUtf8 uname) pwd
    _ -> fail "Could not unpack auth header into username and password components"

loginHandler :: (AU.AuthUser -> Handler App App a) -> Handler App App a
loginHandler onSuccess = do
  req <- getRequest
  rawHeader <- maybe throwChallenge pure $ getHeader "Authorization" req
  let parsedHeader = parseOnly authHeaderParser rawHeader 
  (AuthHeader uname pwd) <- either (throwDenied . AU.AuthError) pure parsedHeader
  authResult <- with auth $ AU.loginByUsername uname (AU.ClearText pwd) False
  either throwDenied onSuccess authResult

throwChallenge :: MonadSnap m => m a
throwChallenge = do
    modifyResponse $ (setResponseStatus 401 "Unauthorized") . 
                     (setHeader "WWW-Authenticate" "Basic realm=quixotic")
    getResponse >>= finishWith
throwDenied :: MonadSnap m => AU.AuthFailure -> m a
throwDenied failure = do
    modifyResponse $ setResponseStatus 403 "Access Denied"
    writeText $ "Access Denied: " <> tshow failure
    getResponse >>= finishWith

{-# LANGUAGE FlexibleInstances #-} 
{-# LANGUAGE TemplateHaskell #-}
module Quixotic.Api where

module Quixotic.Snaplet.WorkLog where

import Data.Map

import Quixotic.Api.Types

import Quixotic.Snaplet
import Quixotic.Snaplet.Auth

logWorkHandler evType = requireUserId $ \uid -> do 

logWorkHandler evType = do 

  pid <- getParam "projectId"
  checkProjectAccess pid uid

  uid <- requireUserId
  pid <- requireProjectAccess uid

loggedIntervalsHandler = requireLogin $ do

loggedIntervalsHandler = do

  widx <- liftPG $ runReaderT readWorkIndex

  uid <- requireUserId 
  pid <- requireProjectAccess uid
  widx <- liftPG . runReaderT $ readWorkIndex pid

  writeLBS . A.encode $ mapKeys (^. address) widx

  writeLBS . A.encode . fmap (fmap IntervalJ) $ mapKeysWith (++) (^. address) widx

payoutsHandler = requireLogin $ do 

payoutsHandler = do 

  uid <- requireUserId 
  pid <- requireProjectAccess uid
  widx <- liftPG . runReaderT $ readWorkIndex pid

  widx <- liftPG $ runReaderT readWorkIndex

{-# LANGUAGE FlexibleInstances #-} 
{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE TemplateHaskell, FlexibleInstances #-}

module Quixotic.Api.Types where

module Quixotic.Snaplet where

import Quixotic

requireLogin :: Handler App App a -> Handler App App a
requireLogin = AU.requireUser auth (redirect "/login")
requireUserId :: (UserId -> Handler App App a) -> Handler App App a 
requireUserId hf = AU.requireUser auth (redirect "/login") $ do
  QDB{..} <- view qdb <$> with qm get
  authedUser <- with auth AU.currentUser
  qdbUser <- case UserName . AU.unUid <$> (AU.userId =<< authedUser) of 
    Nothing -> snapError 403 "User is authenticated, but session lacks user identifier"
    Just n  -> liftPG . runReaderT $ findUserByUserName n
  case qdbUser of
    Nothing -> snapError 403 "Unable to retrieve user record for authenticated user" 
    Just u -> hf (u ^. userId)
checkProjectAccess :: ProjectId -> UserId -> Handler App App a
checkProjectAccess = undefined