{-
Copyright (C) 2013 John Lenz <lenz@math.uic.edu>

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU Affero General Public License for more details.

You should have received a copy of the GNU Affero General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}
module Foundation where

import Prelude
import Yesod
import Yesod.Auth
import Yesod.Static
import Yesod.Default.Config
import Yesod.Default.Util (addStaticContentExternal)
import Network.HTTP.Conduit (Manager)
import Data.Monoid (mappend)
import qualified Settings
import StaticFiles
import Settings (widgetFile, Extra (..))
import Network.Wai (requestHeaders)
import Data.Maybe (isJust)
import Text.Jasmine (minifym)
import Web.ClientSession (getKey)
import Text.Hamlet (hamletFile)
import NotmuchCmd (ThreadID, MessageID)
import Control.Applicative
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
import qualified Crypto.PasswordStore as PS
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as T

-- | The site argument for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have
-- access to the data present here.
data App = App
    { settings :: AppConfig DefaultEnv Extra
    , getStatic :: Static -- ^ Settings for static file serving.
    , httpManager :: Manager
    , passwordHash :: B.ByteString -- ^ hashed password from "Crypto.PasswordStore"
    }

-- Set up i18n messages. See the message folder.
mkMessage "App" "messages" "en"

-- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see:
-- http://www.yesodweb.com/book/handler
--
-- This function does three things:
--
-- * Creates the route datatype AppRoute. Every valid URL in your
--   application can be represented as a value of this type.
-- * Creates the associated type:
--       type instance Route App = AppRoute
-- * Creates the value resourcesApp which contains information on the
--   resources declared below. This is used in Handler.hs by the call to
--   mkYesodDispatch
--
-- What this function does *not* do is create a YesodSite instance for
-- App. Creating that instance requires all of the handler functions
-- for our application to be in scope. However, the handler functions
-- usually require access to the AppRoute datatype. Therefore, we
-- split these actions into two functions and place them in separate files.
mkYesodData "App" $(parseRoutesFile "config/routes")

type Form x = Html -> MForm App App (FormResult x, Widget)

-- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here.
instance Yesod App where
    approot = ApprootMaster $ appRoot . settings

    -- Require authentication for most routes
    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

    -- Store session data on the client in encrypted cookies,
    -- default session idle timeout is 120 minutes
    makeSessionBackend _ = do
        key <- getKey "config/client_session_key.aes"
        (gd, _) <- clientSessionDateCacher $ fromIntegral (120 * 60 :: Int)
        return . Just $ clientSessionBackend2 key gd

    defaultLayout widget = do
        master <- getYesod
        mmsg <- getMessage
        let folders = extraFolders $ appExtra $ settings master

        pjax <- isPjax
        if pjax
          then do pc <- widgetToPageContent widget
                  hamletToRepHtml $ 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_9_1_min_js
                          addScript $ StaticR js_bootstrap_min_js
                          $(widgetFile "default-layout")

                  hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet")

    -- This is done to provide an optimization for serving static files from
    -- a separate domain. Please see the staticRoot setting in Settings.hs
    urlRenderOverride y (StaticR s) =
        Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s

    -- The opensearch.xml file must include {searchTerms} in the url template, but
    -- the default url renderer percent encodes the braces which doesn't work.  So we
    -- need to directly render just this single example, leaving the rest of the search
    -- rotues to the default renderer.
    urlRenderOverride y (SearchR "{searchTerms}") = Just url
        where
          emptysearch = uncurry (joinPath y (appRoot $ settings y)) $ renderRoute $ SearchR " "
          url = emptysearch `mappend` fromText "{searchTerms}"

    urlRenderOverride _ _ = Nothing

    -- This function creates static content files in the static folder
    -- and names them based on a hash of their content. This allows
    -- expiration dates to be set far in the future without worry of
    -- users receiving stale content.
    addStaticContent = addStaticContentExternal mini base64md5 Settings.staticDir (StaticR . flip StaticRoute [])
      where mini = if Settings.development then Right else minifym

    -- Place Javascript at bottom of the body tag so the rest of the page loads first
    jsLoader _ = BottomOfBody

    -- What messages should be logged. The following includes all messages when
    -- in development, and warnings and errors in production.
    shouldLog _ _source level =
        Settings.development || level == LevelWarn || level == LevelError

-- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages.
instance RenderMessage App FormMessage where
    renderMessage _ _ = defaultFormMessage

-- | Get the 'Extra' value, used to hold data from the settings.yml file.
getExtra :: GHandler s App Extra
getExtra = fmap (appExtra . settings) getYesod

-- | Checks if the request comes from pjax
isPjax :: GHandler s App Bool
isPjax = do r <- waiRequest
            return $ isJust $ lookup "X-PJAX" $ requestHeaders r

loginForm :: AForm s App B.ByteString
loginForm = T.encodeUtf8 <$> areq passwordField pwd Nothing
  where pwd = FieldSettings (SomeMessage MsgPassword) Nothing (Just "Password") Nothing []

instance YesodAuth App where
    type AuthId App = T.Text
    loginDest _  = HomeR
    logoutDest _ = HomeR
    getAuthId (Creds _ n _) = return $ Just n
    authPlugins _ = [passwordPlugin]
    authHttpManager _ = error "Manager not needed"

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) <- lift $ runFormPostNoToken $ renderDivs loginForm
              [whamlet|
<form method=post enctype=#{enctype} action=@{loginR}>
    ^{widget}
    <input type=submit value=_{MsgLogin}>
|]

          postLoginR = 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"