Commit f3d72f0a authored by Ibnu Daru Aji's avatar Ibnu Daru Aji

Added development mode.

parent fe886b3b
......@@ -19,4 +19,4 @@ cabal.sandbox.config
*~
\#*
TAGS
Cirkeltrek.cabal
\ No newline at end of file
*.cabal
......@@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: ac82d237ef701a1dbc867cec1e99eb5d5bb8ad007265c41dc76968c2c000666f
-- hash: fd7a7246f0613d88e47e6f2e5ce057afc082ed5215a32651d8e7e52850604853
name: Cirkeltrek
version: 0.0.0
......@@ -26,6 +26,7 @@ library
, base
, classy-prelude
, classy-prelude-yesod
, data-default
, esqueleto
, fast-logger
, file-embed
......@@ -63,6 +64,7 @@ executable Cirkeltrek
, base
, classy-prelude
, classy-prelude-yesod
, data-default
, esqueleto
, fast-logger
, file-embed
......
import Application (newMain) -- for YesodDispatch instance
import Foundation
import Yesod.Core
import Application (newMain)
import Foundation
import Yesod.Core
main :: IO ()
main = newMain
{-# LANGUAGE PackageImports #-}
import "Cirkeltrek" Application (develMain)
import Prelude (IO)
main = develMain
......@@ -6,6 +6,7 @@ dependencies:
- aeson
- classy-prelude
- classy-prelude-yesod
- data-default
- esqueleto
- fast-logger
- file-embed
......
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
......@@ -7,22 +8,27 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application where
import ClassyPrelude.Yesod
import Control.Monad
import Control.Monad.Logger
import Database.Persist.Postgresql
import Foundation
import Language.Haskell.TH.Syntax
import Network.HTTP.Client.TLS
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp
import Network.Wai.Middleware.RequestLogger
import System.Log.FastLogger
import Yesod.Core
import Yesod.Core.Types (loggerSet)
import Yesod.Default.Config2
import Yesod.Static
import Home
import Model
import Settings (ApplicationSettings (..),
configSettingsYmlValue)
import Settings (ApplicationSettings (..),
configSettingsYmlValue)
mkYesodDispatch "App" resourcesApp
......@@ -63,10 +69,22 @@ warpSettings app =
(toLogStr $ "Exception from warp: " ++ show exception))
defaultSettings
makeLogware :: App -> IO Middleware
makeLogware app = do
mkRequestLogger
def
{ outputFormat =
if appDetailedRequestLogging $ appSettings app
then Detailed True
else Apache FromFallback
, destination = Logger $ loggerSet $ appLogger app
}
makeApplication :: App -> IO Application
makeApplication app = do
logware <- makeLogware app
commonapp <- toWaiApp app
return $ defaultMiddlewaresNoLogging commonapp
return $ logware $ defaultMiddlewaresNoLogging commonapp
newMain :: IO ()
newMain = do
......@@ -74,3 +92,19 @@ newMain = do
app <- makeFoundation settings
commonapp <- makeApplication app
runSettings (warpSettings app) commonapp
-- DEVEL
getAppSettings :: IO ApplicationSettings
getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
getAppDev :: IO (Settings, Application)
getAppDev = do
settings <- getAppSettings
found <- makeFoundation settings
warpsettings <- getDevSettings $ warpSettings found
app <- makeApplication found
return (warpsettings, app)
develMain :: IO ()
develMain = develMainHelper getAppDev
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Foundation where
......@@ -13,11 +14,15 @@ import ClassyPrelude.Yesod
import Database.Persist.Sql
import Network.HTTP.Client
import Text.Hamlet
import Yesod.Auth
import Yesod.Auth.HashDB
import Yesod.Auth.Message
import Yesod.Core
import Yesod.Core.Types
import Yesod.Form
import Yesod.Static
import Model
import Settings
data App = App
......@@ -53,7 +58,7 @@ instance Yesod App where
$maybe route <- mcurrentroute
<p> You're at #{show route}.
$nothing
<p> You're lost.
<p> Apparently you're lost.
^{widget}
|]
withUrlRenderer $(hamletFile "templates/wrapper.hamlet")
......@@ -64,3 +69,19 @@ instance YesodPersist App where
master <- getYesod
runSqlPool action $ appConnectionPool master
instance RenderMessage App FormMessage where
renderMessage _ _ = defaultFormMessage
instance YesodAuth App where
type AuthId App = UsersId
loginDest _ = HomeR
logoutDest _ = HomeR
redirectToReferer _ = False
authPlugins _ = [authHashDB (Just . UniqueUsername)]
authenticate creds = liftHandler $ runDB $ do
x <- getBy $ UniqueUsername $ credsIdent creds
case x of
Nothing -> return $ UserError InvalidLogin
Just (Entity uid _) -> return $ Authenticated uid
instance YesodAuthPersist App
......@@ -4,7 +4,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitParams #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
......@@ -13,6 +13,7 @@ module Model where
import ClassyPrelude.Yesod
import Database.Persist.TH
import Yesod.Auth.HashDB
import Model.Grouping
......@@ -94,3 +95,7 @@ share
zappedBy UsersId Maybe
deriving Show Eq
|]
instance HashDBUser Users where
userPasswordHash = usersPassword
setPasswordHash h u = u {usersPassword = Just h}
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment