web: disable persistence/authentication support for now

hledger-web/Hledger/Web/App.hs

@@ -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
+The web app providing a richer interface to hledger's data.
-authentication, registration and persistent storage of user accounts.
 -}
+-- 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
+    --   withConnectionPool
-    , runConnectionPool
+    -- , 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|
+-- mkPersist [$persist|
-User
+-- User
-    ident String
+--     ident String
-    password String null update
+--     password String null update
-    UniqueUser ident
+--     UniqueUser ident
-Email
+-- Email
-    email String
+--     email String
-    user UserId null update
+--     user UserId null update
-    verkey String null update
+--     verkey String null update
-    UniqueEmail email
+--     UniqueEmail email
-|]
+-- |]
 
 -- run-time data kept by the web app.
 data App = App
-    {appConnPool :: Maybe ConnectionPool
+    { -- appConnPool :: Maybe ConnectionPool
-    ,appRoot    :: String
+     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
+-- instance YesodPersist App where
-    type YesodDB App = SqlPersist
+--     type YesodDB App = SqlPersist
-    runDB db = do
+--     runDB db = do
-      y <- getYesod
+--       y <- getYesod
-      let p = appConnPool y
+--       let p = appConnPool y
-      case p of Just p' -> runConnectionPool db p'
+--       case p of Just p' -> runConnectionPool db p'
-                Nothing -> error "no connection pool, programmer error" -- XXX
+--                 Nothing -> error "no connection pool, programmer error" -- XXX
 
-instance YesodAuth App where
+-- instance YesodAuth App where
-    type AuthEntity App = User
+--     type AuthEntity App = User
-    type AuthEmailEntity App = Email
+--     type AuthEmailEntity App = Email
 
-    defaultDest _ = IndexR
+--     defaultDest _ = IndexR
 
-    getAuthId creds _extra = runDB $ do
+--     getAuthId creds _extra = runDB $ do
-        x <- getBy $ UniqueUser $ credsIdent creds
+--         x <- getBy $ UniqueUser $ credsIdent creds
-        case x of
+--         case x of
-            Just (uid, _) -> return $ Just uid
+--             Just (uid, _) -> return $ Just uid
-            Nothing -> do
+--             Nothing -> do
-                fmap Just $ insert $ User (credsIdent creds) Nothing
+--                 fmap Just $ insert $ User (credsIdent creds) Nothing
 
-    openIdEnabled _ = True
+--     openIdEnabled _ = True
 
-    emailSettings _ = Just EmailSettings {
+--     emailSettings _ = Just EmailSettings {
-          addUnverified = \email verkey -> runDB $ insert $ Email email Nothing (Just verkey)
+--           addUnverified = \email verkey -> runDB $ insert $ Email email Nothing (Just verkey)
-        , sendVerifyEmail = sendVerifyEmail'
+--         , sendVerifyEmail = sendVerifyEmail'
-        , getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get
+--         , getVerifyKey = runDB . fmap (join . fmap emailVerkey) . get
-        , setVerifyKey = \eid key -> runDB $ update eid [EmailVerkey $ Just key]
+--         , setVerifyKey = \eid key -> runDB $ update eid [EmailVerkey $ Just key]
-        , verifyAccount = \eid -> runDB $ do
+--         , verifyAccount = \eid -> runDB $ do
-            me <- get eid
+--             me <- get eid
-            case me of
+--             case me of
-                Nothing -> return Nothing
+--                 Nothing -> return Nothing
-                Just e -> do
+--                 Just e -> do
-                    let email = emailEmail e
+--                     let email = emailEmail e
-                    case emailUser e of
+--                     case emailUser e of
-                        Just uid -> return $ Just uid
+--                         Just uid -> return $ Just uid
-                        Nothing -> do
+--                         Nothing -> do
-                            uid <- insert $ User email Nothing
+--                             uid <- insert $ User email Nothing
-                            update eid [EmailUser $ Just uid]
+--                             update eid [EmailUser $ Just uid]
-                            return $ Just uid
+--                             return $ Just uid
-        , getPassword = runDB . fmap (join . fmap userPassword) . get
+--         , getPassword = runDB . fmap (join . fmap userPassword) . get
-        , setPassword = \uid pass -> runDB $ update uid [UserPassword $ Just pass]
+--         , setPassword = \uid pass -> runDB $ update uid [UserPassword $ Just pass]
-        , getEmailCreds = \email -> runDB $ do
+--         , getEmailCreds = \email -> runDB $ do
-            me <- getBy $ UniqueEmail email
+--             me <- getBy $ UniqueEmail email
-            case me of
+--             case me of
-                Nothing -> return Nothing
+--                 Nothing -> return Nothing
-                Just (eid, e) -> return $ Just EmailCreds
+--                 Just (eid, e) -> return $ Just EmailCreds
-                    { emailCredsId = eid
+--                     { emailCredsId = eid
-                    , emailCredsAuthId = emailUser e
+--                     , emailCredsAuthId = emailUser e
-                    , emailCredsStatus = isJust $ emailUser e
+--                     , emailCredsStatus = isJust $ emailUser e
-                    , emailCredsVerkey = emailVerkey e
+--                     , emailCredsVerkey = emailVerkey e
-                    }
+--                     }
-        , getEmail = runDB . fmap (fmap emailEmail) . get
+--         , getEmail = runDB . fmap (fmap emailEmail) . get
-        }
+--         }
 
-sendVerifyEmail' :: String -> String -> String -> GHandler Auth m ()
+-- sendVerifyEmail' :: String -> String -> String -> GHandler Auth m ()
-sendVerifyEmail' email _ verurl =
+-- sendVerifyEmail' email _ verurl =
-    liftIO $ renderSendMail Mail
+--     liftIO $ renderSendMail Mail
-            { mailHeaders =
+--             { mailHeaders =
-                [ ("From", "noreply")
+--                 [ ("From", "noreply")
-                , ("To", email)
+--                 , ("To", email)
-                , ("Subject", "Verify your email address")
+--                 , ("Subject", "Verify your email address")
-                ]
+--                 ]
-            , mailPlain = verurl
+--             , mailPlain = verurl
-            , mailParts = return Part
+--             , mailParts = return Part
-                { partType = "text/html; charset=utf-8"
+--                 { partType = "text/html; charset=utf-8"
-                , partEncoding = None
+--                 , partEncoding = None
-                , partDisposition = Inline
+--                 , partDisposition = Inline
-                , partContent = renderHamlet id [$hamlet|
+--                 , partContent = renderHamlet id [$hamlet|
-%p Please confirm your email address by clicking on the link below.
+-- %p Please confirm your email address by clicking on the link below.
-%p
+-- %p
-    %a!href=$verurl$ $verurl$
+--     %a!href=$verurl$ $verurl$
-%p Thank you
+-- %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.
+-- -- | Obtain a persistent db connection pool to the app, and run any necessary data migrations.
-toPersistentApp :: App -> IO App
+-- toPersistentApp :: App -> IO App
-toPersistentApp app = withConnectionPool $ \p -> do
+-- toPersistentApp app = withConnectionPool $ \p -> do
-    flip runConnectionPool p $ runMigration $ do
+--     flip runConnectionPool p $ runMigration $ do
-        migrate (undefined :: User)
+--         migrate (undefined :: User)
-        migrate (undefined :: Email)
+--         migrate (undefined :: Email)
-        return ()
+--         return ()
-    return app{appConnPool=Just p}
+--     return app{appConnPool=Just p}
 
 
 ----------------------------------------------------------------------
@@ -486,15 +489,15 @@ getIndexR = redirect RedirectTemporary defaultroute where defaultroute = Journal
 
 ----------------------------------------------------------------------
 
-getDemoR :: Handler RepHtml
+-- getDemoR :: Handler RepHtml
-getDemoR = do
+-- getDemoR = do
-    mu <- maybeAuth
+--     -- mu <- maybeAuth
-    defaultLayout $ do
+--     defaultLayout $ do
-        h2id <- newIdent
+--         h2id <- newIdent
-        setTitle $ string "hledger front page"
+--         setTitle $ string "hledger front page"
-        addBody $(hamletFile "homepage")
+--         addBody $(hamletFile "homepage")
-        addStyle $(cassiusFile "homepage")
+--         addStyle $(cassiusFile "homepage")
-        addJavascript $(juliusFile "homepage")
+--         addJavascript $(juliusFile "homepage")
 
 ----------------------------------------------------------------------
 

hledger-web/Hledger/Web/Settings.hs

@@ -3,10 +3,10 @@ module Hledger.Web.Settings
     ( hamletFile
     , cassiusFile
     , juliusFile
-    , connStr
+    -- , connStr
-    , ConnectionPool
+    -- , ConnectionPool
-    , withConnectionPool
+    -- , withConnectionPool
-    , runConnectionPool
+    -- , 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 Database.Persist.Sqlite
-import Yesod (MonadCatchIO)
+-- import Yesod (MonadCatchIO)
 import Yesod.Helpers.Static
 
 
@@ -116,19 +116,19 @@ juliusFile x = H.juliusFileDebug $ templatesdir </> (x ++ ".julius")
 -- database
 ----------------------------------------------------------------------
 
-connStr :: String
+-- connStr :: String
-#ifdef PRODUCTION
+-- #ifdef PRODUCTION
-connStr = "production.db3"
+-- connStr = "production.db3"
-#else
+-- #else
-connStr = "debug.db3"
+-- connStr = "debug.db3"
-#endif
+-- #endif
 
-connectionCount :: Int
+-- connectionCount :: Int
-connectionCount = 10
+-- connectionCount = 10
 
-withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a
+-- withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a
-withConnectionPool = withSqlitePool connStr connectionCount
+-- withConnectionPool = withSqlitePool connStr connectionCount
 
-runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a
+-- runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a
-runConnectionPool = runSqlPool
+-- runConnectionPool = runSqlPool
 

hledger-web/Main.hs

@@ -74,8 +74,8 @@ server baseurl port opts args j = do
     -- dir <- getDataFileName ""
     -- let staticdir = dir </> "static"
     withApp App{
-              appConnPool=Nothing
+              -- appConnPool=Nothing
-             ,appRoot=baseurl
+              appRoot=baseurl
              ,appDataDir=datadir
              ,appStatic=fileLookupDir staticdir $ typeByExt -- ++[("hamlet","text/plain")]
              ,appOpts=opts

hledger-web/hledger-web.cabal

@@ -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 == 0.2.*
-                 ,persistent-sqlite == 0.2.*
+                 -- ,persistent-sqlite == 0.2.*
                  ,template-haskell == 2.4.*
                  ,wai-extra == 0.2.*