nuttycom/aftok - Change BROSTG5KP3NUNLSYPVQID254TE47E5RKQAKLPIY7PGWETE6JNMTAC

Beginning of modularization of server.

Created by Kris Nuttycombe on January 20, 2015

BROSTG5KP3NUNLSYPVQID254TE47E5RKQAKLPIY7PGWETE6JNMTAC

Dependencies

In channels

main

Change contents

Deletion in lib/Quixotic/TimeLog.hs at line 1 [3.846]

B:BD[3.846] → [4.3390:3497]

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

Insertion in quixotic.cabal at line 18 [6.1]

[5.270]

[6.554]

  default-extensions: NoImplicitPrelude
                    , OverloadedStrings
                    , RecordWildCards
                    , ScopedTypeVariables

Insertion in quixotic.cabal at line 60 [6.1]

[6.1496]

[7.2112]

  default-extensions: NoImplicitPrelude
                    , OverloadedStrings
                    , RecordWildCards
                    , ScopedTypeVariables

Insertion in quixotic.cabal at line 80 [6.1]

[6.1833]

  default-extensions: NoImplicitPrelude
                    , OverloadedStrings
                    , RecordWildCards
                    , ScopedTypeVariables

Insertion in quixotic.cabal at line 88 [6.1]
[8.1277]
[8.1277]
```
    , bytestring
```
Insertion in quixotic.cabal at line 107 [6.1]
[9.7467]
[9.7467]
```
    , attoparsec
    , base64-bytestring
```

Insertion in quixotic.cabal at line 115 [6.1]

[10.3346]

  default-extensions: NoImplicitPrelude
                    , OverloadedStrings
                    , RecordWildCards
                    , ScopedTypeVariables

File deletion: Api
BF:BFD[11.1243] → [12.548:562]
BF:BFD[12.562] → [12.547:547]
File deletion: Api.hs
BF:BFD[11.1243] → [12.1533:1563]
BF:BFD[12.1563] → [12.1490:1490]
B:BD[12.1490] → [12.1491:1532]
```
module Api (api) where
import Rest.API
```

Deletion in server/Main.hs at line 1 [13.5188]

B:BD[13.5188] → [14.897:1040]

{-# LANGUAGE ScopedTypeVariables #-} 
{-# LANGUAGE OverloadedStrings #-} 
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}

Insertion in server/Main.hs at line 24 [13.5188]

[15.943]

[12.1565]

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

Deletion in server/Main.hs at line 47 [13.5188]

B:BD[16.314] → [9.7960:8110]

B:BD[9.8110] → [14.1268:1310]

∅:D[14.1310] → [9.8149:8170]

B:BD[9.8149] → [9.8149:8170]


type PQDB = QDB (ReaderT Connection IO)
data App = App 
  { _qdb  :: Snaplet PQDB
  , _sess :: Snaplet SessionManager
  , _db   :: Snaplet Postgres
  , _auth :: Snaplet (AU.AuthManager App)
  }
makeLenses ''App

Deletion in server/Main.hs at line 48 [13.5188]

B:BD[16.315] → [14.1311:1454]

instance HasPostgres (Handler b App) where
    getPostgresState = with db get
    setLocalPostgresState s = local (set (db . snapletValue) s)

Replacement in server/Main.hs at line 62 [13.5188]

B:BD[9.8755] → [9.8755:8817]

  addRoutes [ ("logStart/:btcAddr", logWorkHandler StartWork)

[9.8755]

[9.8817]

  addRoutes [ ("login", loginHandler) 
            , ("register", registerHandler)
            , ("logStart/:btcAddr", logWorkHandler StartWork)

Replacement in server/Main.hs at line 66 [13.5188]

B:BD[9.8878] → [9.8878:8999]

--            , ("loggedIntervals/:btcAddr", loggedIntervalsHandler qdb)
--            , ("payouts", payoutsHandler qdb)

[9.8878]

[9.8999]

            , ("loggedIntervals/:btcAddr", loggedIntervalsHandler qdb)
            , ("payouts", payoutsHandler qdb)

Deletion in server/Main.hs at line 96 [13.5188]

∅:D[17.468] → [13.5695:5696]

∅:D[18.1197] → [13.5695:5696]

∅:D[19.1977] → [13.5695:5696]

∅:D[6.2767] → [13.5695:5696]

B:BD[13.5695] → [13.5695:5696]

B:BD[13.5696] → [2.75:169]

∅:D[2.169] → [9.9241:9373]

B:BD[13.5696] → [9.9241:9373]

∅:D[17.682] → [13.6062:6063]

∅:D[20.884] → [13.6062:6063]

∅:D[19.2061] → [13.6062:6063]

∅:D[6.3037] → [13.6062:6063]

∅:D[9.9373] → [13.6062:6063]

B:BD[13.6062] → [13.6062:6063]

B:BD[13.6063] → [14.1455:2121]

∅:D[14.2121] → [9.9374:9424]

B:BD[13.6063] → [9.9374:9424]

B:BD[9.9424] → [14.2122:2200]

∅:D[14.2200] → [9.9563:9679]

B:BD[9.9563] → [9.9563:9679]

B:BD[9.9679] → [14.2201:2461]

∅:D[14.2461] → [21.981:982]

∅:D[9.9872] → [21.981:982]

B:BD[21.981] → [21.981:982]

B:BD[21.982] → [2.170:441]

∅:D[2.441] → [17.1016:1017]

∅:D[20.1144] → [17.1016:1017]

∅:D[9.10559] → [17.1016:1017]

B:BD[17.1016] → [17.1016:1017]

B:BD[17.1017] → [2.442:750]

∅:D[2.750] → [14.2462:2509]

B:BD[17.1017] → [14.2462:2509]

∅:D[14.2509] → [20.1181:1328]

B:BD[20.1181] → [20.1181:1328]


-- | FIXME, make configurable
depf :: DepF
depf = linearDepreciation (Months 6) (Months 60) 
qdbpgSnapletInit :: SnapletInit a PQDB
qdbpgSnapletInit = makeSnaplet "qdbpg" "QDB on Postgresql" Nothing $ do
  return postgresQDB
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{..} <- with qdb 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)
logWorkHandler :: EventType -> Handler App App ()
logWorkHandler evType = requireUserId $ \uid -> do 
  QDB{..} <- with qdb get
  addrBytes <- getParam "btcAddr"
  timestamp <- liftIO getCurrentTime
  let workEvent = WorkEvent evType timestamp
      storeEv addr = runReaderT . recordEvent uid $ LogEntry addr workEvent
  case fmap decodeUtf8 addrBytes >>= parseBtcAddr of
    Nothing -> snapError 400 $ "Unable to parse bitcoin address from " <> (tshow addrBytes)
    Just addr -> liftPG $ storeEv addr
loggedIntervalsHandler :: Handler App App ()
loggedIntervalsHandler = requireLogin $ do
  QDB{..} <- with qdb get
  widx <- liftPG $ runReaderT readWorkIndex
  modifyResponse $ addHeader "content-type" "application/json"
  writeLBS . A.encode $ mapKeys (^. address) widx
payoutsHandler :: Handler App App ()
payoutsHandler = requireLogin $ do 
  QDB{..} <- with qdb get
  ptime <- liftIO $ getCurrentTime
  widx <- liftPG $ runReaderT readWorkIndex
  modifyResponse $ addHeader "content-type" "application/json"
  writeLBS . A.encode . PayoutsResponse $ payouts depf ptime widx
snapError :: MonadSnap m => Int -> Text -> m a
snapError c t = do
  modifyResponse $ setResponseStatus c $ encodeUtf8 t
  writeText $ ((tshow c) <> " - " <> t)
  r <- getResponse
  finishWith r

File addition: Quixotic (d--x------)
[11.1243]
File addition: Api (d--x------)
[0.1049]

File addition: Types.hs (----------)

[0.1071]

{-# LANGUAGE FlexibleInstances #-} 
{-# LANGUAGE TemplateHaskell #-}
module Quixotic.Api.Types where
import ClassyPrelude 
import Control.Lens
import Control.Monad.Reader
import Control.Monad.State
import Database.PostgreSQL.Simple
import Quixotic.Database
import Quixotic.Database.PostgreSQL
import Quixotic.TimeLog
import Quixotic.Users
import Snap.Core
import Snap.Snaplet
import Snap.Snaplet.PostgresqlSimple
import qualified Snap.Snaplet.Auth as AU
import Snap.Snaplet.Session
data QModules = QModules 
  { _qdb :: QDB (ReaderT Connection IO) 
  , _depf :: DepF
  }
makeLenses ''QModules
data App = App 
  { _qm  :: Snaplet QModules
  , _sess :: Snaplet SessionManager
  , _db   :: Snaplet Postgres
  , _auth :: Snaplet (AU.AuthManager App)
  }
makeLenses ''App
instance HasPostgres (Handler b App) where
    getPostgresState = with db get
    setLocalPostgresState s = local (set (db . snapletValue) s)
-- | FIXME, make configurable
qdbpgSnapletInit :: SnapletInit a QModules
qdbpgSnapletInit = makeSnaplet "qdbpg" "QDB on Postgresql" Nothing $ do
  pure $ QModules postgresQDB $ linearDepreciation (Months 6) (Months 60) 
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)
snapError :: MonadSnap m => Int -> Text -> m a
snapError c t = do
  modifyResponse $ setResponseStatus c $ encodeUtf8 t
  writeText $ ((tshow c) <> " - " <> t)
  getResponse >>= finishWith
ok :: MonadSnap m => m ()
ok = do
  modifyResponse $ setResponseCode 200
  getResponse >>= finishWith

File addition: Users.hs (----------)

[0.1071]

{-# LANGUAGE ScopedTypeVariables #-} 
{-# LANGUAGE OverloadedStrings #-} 
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-} 
{-# LANGUAGE TemplateHaskell #-}
module Quixotic.Api.Users 
  ( loginHandler
  , registerHandler
  ) where
import ClassyPrelude 
import Data.ByteString (split)
import Data.Attoparsec.ByteString 
import qualified Data.ByteString.Base64 as B64
import Quixotic.Api.Types
import Snap.Core
import Snap.Snaplet
import qualified Snap.Snaplet.Auth as AU
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"
-- data CreateUser = CreateUser
--   { _user :: User
--   , _password :: ByteString
--   }
-- makeLenses ''CreateUser
loginHandler :: (AU.AuthUser -> Handler App App a) -> Handler App App a
loginHandler onSuccess = do
  req <- getRequest
  rawHeader <- maybe throwChallenge pure $ getHeader "Authorization" req
  (AuthHeader uname pwd) <- either (throwDenied . AU.AuthError) pure $ parseOnly authHeaderParser rawHeader 
  authResult <- with auth $ AU.loginByUsername uname (AU.ClearText pwd) False
  either throwDenied onSuccess authResult
registerHandler :: Handler App App ()
registerHandler = ok
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

File move: WorkLog.hs → WorkLog.hs
BF:BFD[12.547] → [12.1453:1487]
BF:BF[12.1487] → [12.564:564]
[0.1071]
[12.564]

File addition: Api.hs (----------)

[0.1049]

{-# LANGUAGE FlexibleInstances #-} 
{-# LANGUAGE TemplateHaskell #-}
module Quixotic.Api where
import ClassyPrelude 
import Control.Lens
import Control.Monad.State
import qualified Data.Aeson as A
import Data.Map
import Quixotic
import Quixotic.Database
import Quixotic.Json
import Quixotic.TimeLog
import Quixotic.Api.Types
import Snap.Core
import Snap.Snaplet
import Snap.Snaplet.PostgresqlSimple
logWorkHandler :: EventType -> Handler App App ()
logWorkHandler evType = requireUserId $ \uid -> do 
  QDB{..} <- view qdb <$> with qm get
  addrBytes <- getParam "btcAddr"
  timestamp <- liftIO getCurrentTime
  let workEvent = WorkEvent evType timestamp
      storeEv addr = runReaderT . recordEvent uid $ LogEntry addr workEvent
  case fmap decodeUtf8 addrBytes >>= parseBtcAddr of
    Nothing -> snapError 400 $ "Unable to parse bitcoin address from " <> (tshow addrBytes)
    Just addr -> liftPG $ storeEv addr
loggedIntervalsHandler :: Handler App App ()
loggedIntervalsHandler = requireLogin $ do
  QDB{..} <- view qdb <$> with qm get
  widx <- liftPG $ runReaderT readWorkIndex
  modifyResponse $ addHeader "content-type" "application/json"
  writeLBS . A.encode $ mapKeys (^. address) widx
payoutsHandler :: Handler App App ()
payoutsHandler = requireLogin $ do 
  (QModules QDB{..} df) <- with qm get
  ptime <- liftIO $ getCurrentTime
  widx <- liftPG $ runReaderT readWorkIndex
  modifyResponse $ addHeader "content-type" "application/json"
  writeLBS . A.encode . PayoutsResponse $ payouts df ptime widx