module Foundation where
import Prelude
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
import Control.Applicative
import Data.ByteString (ByteString)
import Data.Maybe (isJust)
import Data.Monoid (mappend)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Network.HTTP.Conduit (Manager)
import Network.Wai (requestHeaders)
import NotmuchCmd (ThreadID, MessageID)
import Settings (widgetFile, Extra (..), development)
import StaticFiles
import Text.Hamlet (hamletFile)
import Text.Jasmine (minifym)
import Yesod
import Yesod.Auth
import Yesod.Default.Config
import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Static
import qualified Crypto.PasswordStore as PS
data App = App
{ settings :: AppConfig DefaultEnv Extra
, getStatic :: Static
, httpManager :: Manager
, passwordHash :: ByteString
}
mkMessage "App" "messages" "en"
mkYesodData "App" $(parseRoutesFile "config/routes")
type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
instance Yesod App where
approot = ApprootMaster $ appRoot . settings
isAuthorized (AuthR _) _ = return Authorized
isAuthorized RobotsR _ = return Authorized
isAuthorized FaviconR _ = return Authorized
isAuthorized (StaticR _) _ = return Authorized
isAuthorized _ _ = do
mauth <- maybeAuthId
case mauth of
Nothing -> return AuthenticationRequired
Just _ -> return Authorized
authRoute _ = Just $ AuthR LoginR
makeSessionBackend _ = fmap Just $ defaultClientSessionBackend 120 "config/client_session_key.aes"
defaultLayout widget = do
master <- getYesod
mmsg <- getMessage
let folders = extraFolders $ appExtra $ settings master
sourceLink <- extraSourceLink <$> getExtra
pjax <- isPjax
if pjax
then do pc <- widgetToPageContent widget
giveUrlRenderer $ pageBody pc
else do pc <- widgetToPageContent $ do
addStylesheet $ StaticR css_bootstrap_min_css
addStylesheet $ StaticR css_bootstrap_responsive_min_css
addScript $ StaticR js_jquery_1_10_1_min_js
addScript $ StaticR js_bootstrap_min_js
let newFrm extra = do (_,x) <- mreq hiddenField "" $ Just ("new" :: String)
return (FormMissing, [whamlet|#{extra} ^{fvInput x}|])
(newWidget,newEnctype) <- liftHandlerT $ generateFormPost newFrm
$(widgetFile "default-layout")
giveUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
urlRenderOverride y (SearchR "{searchTerms}") = Just url
where
emptysearch = uncurry (joinPath y (appRoot $ settings y)) $ renderRoute $ SearchR " "
url = emptysearch `mappend` fromText "{searchTerms}"
urlRenderOverride _ _ = Nothing
addStaticContent = addStaticContentExternal mini base64md5 "static" (StaticR . flip StaticRoute [])
where mini = if development then Right else minifym
jsLoader _ = BottomOfBody
shouldLog _ _source level =
development || level == LevelWarn || level == LevelError
instance RenderMessage App FormMessage where
renderMessage _ _ = defaultFormMessage
getExtra :: (MonadHandler m, HandlerSite m ~ App) => m Extra
getExtra = fmap (appExtra . settings) getYesod
isPjax :: (MonadHandler m, HandlerSite m ~ App) => m Bool
isPjax = do r <- waiRequest
return $ isJust $ lookup "X-PJAX" $ requestHeaders r
loginForm :: AForm (HandlerT App IO) ByteString
loginForm = encodeUtf8 <$> areq passwordField pwd Nothing
where pwd = FieldSettings (SomeMessage MsgPassword) Nothing (Just "Password") Nothing []
instance YesodAuth App where
type AuthId App = Text
loginDest _ = HomeR
logoutDest _ = HomeR
getAuthId (Creds _ n _) = return $ Just n
authPlugins _ = [passwordPlugin]
authHttpManager _ = error "Manager not needed"
maybeAuthId = lookupSession "_ID"
passwordPlugin :: AuthPlugin App
passwordPlugin = AuthPlugin "password" dispatch loginWidget
where dispatch "POST" ["login"] = postLoginR >>= sendResponse
dispatch _ _ = notFound
loginR = AuthR (PluginR "password" ["login"])
loginWidget _ = do
((_,widget),enctype) <- liftHandlerT $ runFormPostNoToken $ renderDivs loginForm
[whamlet|
<form method=post enctype=#{enctype} action=@{loginR}>
^{widget}
<input type=submit value=_{MsgLogin}>
|]
postLoginR = lift $ do
((result,_),_) <- runFormPostNoToken $ renderDivs loginForm
case result of
FormMissing -> invalidArgs ["Form is missing"]
FormFailure msg -> invalidArgs msg
FormSuccess pwd -> do
hash <- passwordHash <$> getYesod
if PS.verifyPassword pwd hash
then setCreds True $ Creds "password" "notmuch" []
else permissionDenied "Invalid password"