web: disable persistence/authentication support for now
This commit is contained in:
Simon Michael
parent
8dd52decb2
commit
e04d44a745
@ -1,9 +1,9 @@
|
||||
{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, TypeFamilies, GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}
|
||||
{-|
|
||||
The web app providing a richer interface to hledger's data, along with
|
||||
authentication, registration and persistent storage of user accounts.
|
||||
The web app providing a richer interface to hledger's data.
|
||||
-}
|
||||
-- with authentication, registration and persistent storage of user accounts (not yet)
|
||||
module Hledger.Web.App
|
||||
( App (..)
|
||||
, withApp
|
||||
@ -18,11 +18,11 @@ import System.FilePath ((</>), takeFileName)
|
||||
import System.IO.Storage (putValue, getValue)
|
||||
import Text.ParserCombinators.Parsec hiding (string)
|
||||
|
||||
import Database.Persist.GenericSql (ConnectionPool, SqlPersist, runMigration, migrate)
|
||||
-- import Database.Persist.GenericSql (ConnectionPool, SqlPersist, runMigration, migrate)
|
||||
import Yesod
|
||||
import Yesod.Mail
|
||||
import Yesod.Helpers.Static
|
||||
import Yesod.Helpers.Auth
|
||||
-- import Yesod.Helpers.Auth
|
||||
-- import Yesod.Mail
|
||||
-- import Yesod.WebRoutes
|
||||
import Text.Hamlet (defaultHamletSettings)
|
||||
import Text.Hamlet.RT
|
||||
@ -38,13 +38,13 @@ import Hledger.Data hiding (insert, today)
|
||||
import Hledger.Read (journalFromPathAndString)
|
||||
import Hledger.Read.Journal (someamount)
|
||||
import Hledger.Web.Settings (
|
||||
withConnectionPool
|
||||
, runConnectionPool
|
||||
-- withConnectionPool
|
||||
-- , runConnectionPool
|
||||
-- , staticroot
|
||||
, staticdir
|
||||
staticdir
|
||||
, hamletFile
|
||||
, cassiusFile
|
||||
, juliusFile
|
||||
-- , juliusFile
|
||||
, hledgerorgurl
|
||||
, manualurl
|
||||
, style_css
|
||||
@ -65,22 +65,22 @@ import Hledger.Web.Settings (
|
||||
-- hledger's main data is stored in the usual places (journal files etc.)
|
||||
-- persist (quasi-quoter from persistent) defines a list of data entities.
|
||||
-- mkPersist (template haskell from persistent) defines persistence-capable data types based on these.
|
||||
mkPersist [$persist|
|
||||
User
|
||||
ident String
|
||||
password String null update
|
||||
UniqueUser ident
|
||||
Email
|
||||
email String
|
||||
user UserId null update
|
||||
verkey String null update
|
||||
UniqueEmail email
|
||||
|]
|
||||
-- mkPersist [$persist|
|
||||
-- User
|
||||
-- ident String
|
||||
-- password String null update
|
||||
-- UniqueUser ident
|
||||
-- Email
|
||||
-- email String
|
||||
-- user UserId null update
|
||||
-- verkey String null update
|
||||
-- UniqueEmail email
|
||||
-- |]
|
||||
|
||||
-- run-time data kept by the web app.
|
||||
data App = App
|
||||
{appConnPool :: Maybe ConnectionPool
|
||||
,appRoot :: String
|
||||
{ -- appConnPool :: Maybe ConnectionPool
|
||||
appRoot :: String
|
||||
,appDataDir :: FilePath
|
||||
,appOpts :: [Opt]
|
||||
,appArgs :: [String]
|
||||
@ -90,8 +90,8 @@ data App = App
|
||||
|
||||
-- parseRoutes (quasi-quoter from web-routes) defines a list of route patterns for the web app.
|
||||
-- mkYesod (template haskell from yesod) defines types for the web app based on the routes.
|
||||
-- /auth AuthR Auth getAuth
|
||||
mkYesod "App" [$parseRoutes|
|
||||
/auth AuthR Auth getAuth
|
||||
/favicon.ico FaviconR GET
|
||||
/robots.txt RobotsR GET
|
||||
/static StaticR Static appStatic
|
||||
@ -114,7 +114,8 @@ instance Yesod App where
|
||||
widget
|
||||
addStyle $(cassiusFile "default-layout")
|
||||
hamletToRepHtml $(hamletFile "default-layout")
|
||||
authRoute _ = Just $ AuthR LoginR
|
||||
-- authRoute _ = Just $ AuthR LoginR
|
||||
|
||||
-- static file-serving optimisations, disable for the moment
|
||||
-- urlRenderOverride a (StaticR s) =
|
||||
-- Just $ uncurry (joinPath a staticroot) $ format s
|
||||
@ -130,95 +131,97 @@ instance Yesod App where
|
||||
-- liftIO $ L.writeFile (statictmp ++ fn) content
|
||||
-- return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn] [], [])
|
||||
|
||||
instance YesodPersist App where
|
||||
type YesodDB App = SqlPersist
|
||||
runDB db = do
|
||||
y <- getYesod
|
||||
let p = appConnPool y
|
||||
case p of Just p' -> runConnectionPool db p'
|
||||
Nothing -> error "no connection pool, programmer error" -- XXX
|
||||
-- instance YesodPersist App where
|
||||
-- type YesodDB App = SqlPersist
|
||||
-- runDB db = do
|
||||
-- y <- getYesod
|
||||
-- let p = appConnPool y
|
||||
-- case p of Just p' -> runConnectionPool db p'
|
||||
-- Nothing -> error "no connection pool, programmer error" -- XXX
|
||||
|
||||
instance YesodAuth App where
|
||||
type AuthEntity App = User
|
||||
type AuthEmailEntity App = Email
|
||||
-- instance YesodAuth App where
|
||||
-- type AuthEntity App = User
|
||||
-- type AuthEmailEntity App = Email
|
||||
|
||||
defaultDest _ = IndexR
|
||||
-- defaultDest _ = IndexR
|
||||
|
||||
getAuthId creds _extra = runDB $ do
|
||||
x <- getBy $ UniqueUser $ credsIdent creds
|
||||
case x of
|
||||
Just (uid, _) -> return $ Just uid
|
||||
Nothing -> do
|
||||
fmap Just $ insert $ User (credsIdent creds) Nothing
|
||||
-- getAuthId creds _extra = runDB $ do
|
||||
-- x <- getBy $ UniqueUser $ credsIdent creds
|
||||
-- case x of
|
||||
-- Just (uid, _) -> return $ Just uid
|
||||
-- Nothing -> do
|
||||
-- fmap Just $ insert $ User (credsIdent creds) Nothing
|
||||
|
||||
openIdEnabled _ = True
|
||||
-- openIdEnabled _ = True
|
||||
|
||||
emailSettings _ = Just EmailSettings {
|
||||
addUnverified = \email verkey -> runDB $ insert $ Email email Nothing (Just verkey)
|
||||
, sendVerifyEmail = sendVerifyEmail'
|
||||
, getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get
|
||||
, setVerifyKey = \eid key -> runDB $ update eid [EmailVerkey $ Just key]
|
||||
, verifyAccount = \eid -> runDB $ do
|
||||
me <- get eid
|
||||
case me of
|
||||
Nothing -> return Nothing
|
||||
Just e -> do
|
||||
let email = emailEmail e
|
||||
case emailUser e of
|
||||
Just uid -> return $ Just uid
|
||||
Nothing -> do
|
||||
uid <- insert $ User email Nothing
|
||||
update eid [EmailUser $ Just uid]
|
||||
return $ Just uid
|
||||
, getPassword = runDB . fmap (join . fmap userPassword) . get
|
||||
, setPassword = \uid pass -> runDB $ update uid [UserPassword $ Just pass]
|
||||
, getEmailCreds = \email -> runDB $ do
|
||||
me <- getBy $ UniqueEmail email
|
||||
case me of
|
||||
Nothing -> return Nothing
|
||||
Just (eid, e) -> return $ Just EmailCreds
|
||||
{ emailCredsId = eid
|
||||
, emailCredsAuthId = emailUser e
|
||||
, emailCredsStatus = isJust $ emailUser e
|
||||
, emailCredsVerkey = emailVerkey e
|
||||
}
|
||||
, getEmail = runDB . fmap (fmap emailEmail) . get
|
||||
}
|
||||
-- emailSettings _ = Just EmailSettings {
|
||||
-- addUnverified = \email verkey -> runDB $ insert $ Email email Nothing (Just verkey)
|
||||
-- , sendVerifyEmail = sendVerifyEmail'
|
||||
-- , getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get
|
||||
-- , setVerifyKey = \eid key -> runDB $ update eid [EmailVerkey $ Just key]
|
||||
-- , verifyAccount = \eid -> runDB $ do
|
||||
-- me <- get eid
|
||||
-- case me of
|
||||
-- Nothing -> return Nothing
|
||||
-- Just e -> do
|
||||
-- let email = emailEmail e
|
||||
-- case emailUser e of
|
||||
-- Just uid -> return $ Just uid
|
||||
-- Nothing -> do
|
||||
-- uid <- insert $ User email Nothing
|
||||
-- update eid [EmailUser $ Just uid]
|
||||
-- return $ Just uid
|
||||
-- , getPassword = runDB . fmap (join . fmap userPassword) . get
|
||||
-- , setPassword = \uid pass -> runDB $ update uid [UserPassword $ Just pass]
|
||||
-- , getEmailCreds = \email -> runDB $ do
|
||||
-- me <- getBy $ UniqueEmail email
|
||||
-- case me of
|
||||
-- Nothing -> return Nothing
|
||||
-- Just (eid, e) -> return $ Just EmailCreds
|
||||
-- { emailCredsId = eid
|
||||
-- , emailCredsAuthId = emailUser e
|
||||
-- , emailCredsStatus = isJust $ emailUser e
|
||||
-- , emailCredsVerkey = emailVerkey e
|
||||
-- }
|
||||
-- , getEmail = runDB . fmap (fmap emailEmail) . get
|
||||
-- }
|
||||
|
||||
sendVerifyEmail' :: String -> String -> String -> GHandler Auth m ()
|
||||
sendVerifyEmail' email _ verurl =
|
||||
liftIO $ renderSendMail Mail
|
||||
{ mailHeaders =
|
||||
[ ("From", "noreply")
|
||||
, ("To", email)
|
||||
, ("Subject", "Verify your email address")
|
||||
]
|
||||
, mailPlain = verurl
|
||||
, mailParts = return Part
|
||||
{ partType = "text/html; charset=utf-8"
|
||||
, partEncoding = None
|
||||
, partDisposition = Inline
|
||||
, partContent = renderHamlet id [$hamlet|
|
||||
%p Please confirm your email address by clicking on the link below.
|
||||
%p
|
||||
%a!href=$verurl$ $verurl$
|
||||
%p Thank you
|
||||
|]
|
||||
}
|
||||
}
|
||||
-- sendVerifyEmail' :: String -> String -> String -> GHandler Auth m ()
|
||||
-- sendVerifyEmail' email _ verurl =
|
||||
-- liftIO $ renderSendMail Mail
|
||||
-- { mailHeaders =
|
||||
-- [ ("From", "noreply")
|
||||
-- , ("To", email)
|
||||
-- , ("Subject", "Verify your email address")
|
||||
-- ]
|
||||
-- , mailPlain = verurl
|
||||
-- , mailParts = return Part
|
||||
-- { partType = "text/html; charset=utf-8"
|
||||
-- , partEncoding = None
|
||||
-- , partDisposition = Inline
|
||||
-- , partContent = renderHamlet id [$hamlet|
|
||||
-- %p Please confirm your email address by clicking on the link below.
|
||||
-- %p
|
||||
-- %a!href=$verurl$ $verurl$
|
||||
-- %p Thank you
|
||||
-- |]
|
||||
-- }
|
||||
-- }
|
||||
|
||||
-- | Migrate the app's persistent data and run the given yesod/persistent/wai-ish IO action on it.
|
||||
-- withApp :: App -> (Yesod.Application -> IO a) -> IO a
|
||||
-- withApp app f = toPersistentApp app >>= toWaiApp >>= f
|
||||
withApp :: App -> (Yesod.Application -> IO a) -> IO a
|
||||
withApp app f = toPersistentApp app >>= toWaiApp >>= f
|
||||
withApp app f = toWaiApp app >>= f
|
||||
|
||||
-- | Obtain a persistent db connection pool to the app, and run any necessary data migrations.
|
||||
toPersistentApp :: App -> IO App
|
||||
toPersistentApp app = withConnectionPool $ \p -> do
|
||||
flip runConnectionPool p $ runMigration $ do
|
||||
migrate (undefined :: User)
|
||||
migrate (undefined :: Email)
|
||||
return ()
|
||||
return app{appConnPool=Just p}
|
||||
-- -- | Obtain a persistent db connection pool to the app, and run any necessary data migrations.
|
||||
-- toPersistentApp :: App -> IO App
|
||||
-- toPersistentApp app = withConnectionPool $ \p -> do
|
||||
-- flip runConnectionPool p $ runMigration $ do
|
||||
-- migrate (undefined :: User)
|
||||
-- migrate (undefined :: Email)
|
||||
-- return ()
|
||||
-- return app{appConnPool=Just p}
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
@ -486,15 +489,15 @@ getIndexR = redirect RedirectTemporary defaultroute where defaultroute = Journal
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
getDemoR :: Handler RepHtml
|
||||
getDemoR = do
|
||||
mu <- maybeAuth
|
||||
defaultLayout $ do
|
||||
h2id <- newIdent
|
||||
setTitle $ string "hledger front page"
|
||||
addBody $(hamletFile "homepage")
|
||||
addStyle $(cassiusFile "homepage")
|
||||
addJavascript $(juliusFile "homepage")
|
||||
-- getDemoR :: Handler RepHtml
|
||||
-- getDemoR = do
|
||||
-- -- mu <- maybeAuth
|
||||
-- defaultLayout $ do
|
||||
-- h2id <- newIdent
|
||||
-- setTitle $ string "hledger front page"
|
||||
-- addBody $(hamletFile "homepage")
|
||||
-- addStyle $(cassiusFile "homepage")
|
||||
-- addJavascript $(juliusFile "homepage")
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
|
||||
@ -3,10 +3,10 @@ module Hledger.Web.Settings
|
||||
( hamletFile
|
||||
, cassiusFile
|
||||
, juliusFile
|
||||
, connStr
|
||||
, ConnectionPool
|
||||
, withConnectionPool
|
||||
, runConnectionPool
|
||||
-- , connStr
|
||||
-- , ConnectionPool
|
||||
-- , withConnectionPool
|
||||
-- , runConnectionPool
|
||||
, approot
|
||||
, staticroot
|
||||
, datadir
|
||||
@ -33,8 +33,8 @@ import qualified Text.Hamlet as H
|
||||
import qualified Text.Cassius as H
|
||||
import qualified Text.Julius as H
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Database.Persist.Sqlite
|
||||
import Yesod (MonadCatchIO)
|
||||
-- import Database.Persist.Sqlite
|
||||
-- import Yesod (MonadCatchIO)
|
||||
import Yesod.Helpers.Static
|
||||
|
||||
|
||||
@ -116,19 +116,19 @@ juliusFile x = H.juliusFileDebug $ templatesdir </> (x ++ ".julius")
|
||||
-- database
|
||||
----------------------------------------------------------------------
|
||||
|
||||
connStr :: String
|
||||
#ifdef PRODUCTION
|
||||
connStr = "production.db3"
|
||||
#else
|
||||
connStr = "debug.db3"
|
||||
#endif
|
||||
-- connStr :: String
|
||||
-- #ifdef PRODUCTION
|
||||
-- connStr = "production.db3"
|
||||
-- #else
|
||||
-- connStr = "debug.db3"
|
||||
-- #endif
|
||||
|
||||
connectionCount :: Int
|
||||
connectionCount = 10
|
||||
-- connectionCount :: Int
|
||||
-- connectionCount = 10
|
||||
|
||||
withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a
|
||||
withConnectionPool = withSqlitePool connStr connectionCount
|
||||
-- withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a
|
||||
-- withConnectionPool = withSqlitePool connStr connectionCount
|
||||
|
||||
runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a
|
||||
runConnectionPool = runSqlPool
|
||||
-- runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a
|
||||
-- runConnectionPool = runSqlPool
|
||||
|
||||
|
||||
@ -74,8 +74,8 @@ server baseurl port opts args j = do
|
||||
-- dir <- getDataFileName ""
|
||||
-- let staticdir = dir </> "static"
|
||||
withApp App{
|
||||
appConnPool=Nothing
|
||||
,appRoot=baseurl
|
||||
-- appConnPool=Nothing
|
||||
appRoot=baseurl
|
||||
,appDataDir=datadir
|
||||
,appStatic=fileLookupDir staticdir $ typeByExt -- ++[("hamlet","text/plain")]
|
||||
,appOpts=opts
|
||||
|
||||
@ -75,7 +75,7 @@ executable hledger-web
|
||||
,convertible-text >= 0.3.0.1 && < 0.4
|
||||
,data-object >= 0.3.1.2 && < 0.4
|
||||
,failure >= 0.1 && < 0.2
|
||||
,persistent == 0.2.*
|
||||
,persistent-sqlite == 0.2.*
|
||||
-- ,persistent == 0.2.*
|
||||
-- ,persistent-sqlite == 0.2.*
|
||||
,template-haskell == 2.4.*
|
||||
,wai-extra == 0.2.*
|
||||
|
||||
Loading…
Reference in New Issue
Block a user