vervis/src/Vervis/Foundation.hs

{- This file is part of Vervis.
 -
 - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

module Vervis.Foundation where

import Prelude (init, last)

import Control.Monad.Trans.Maybe
import Database.Persist.Sql (ConnectionPool, runSqlPool)
import Text.Hamlet          (hamletFile)
--import Text.Jasmine         (minifym)
import Yesod.Auth.HashDB    (authHashDB)
import Yesod.Auth.Message   (AuthMessage (IdentifierNotFound))
import Yesod.Default.Util   (addStaticContentExternal)
import Yesod.Core.Types     (Logger)

import qualified Yesod.Core.Unsafe as Unsafe
--import qualified Data.CaseInsensitive as CI
import Data.Text as T (pack, intercalate)
--import qualified Data.Text.Encoding as TE

import Text.Jasmine.Local (discardm)
import Vervis.Import.NoFoundation hiding (last)
import Vervis.Model.Group
import Vervis.Model.Ident
import Vervis.Model.Role
import Vervis.Widget (breadcrumbsW, revisionW)

-- | The foundation datatype 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
    { appSettings    :: AppSettings
    , appStatic      :: Static -- ^ Settings for static file serving.
    , appConnPool    :: ConnectionPool -- ^ Database connection pool.
    , appHttpManager :: Manager
    , appLogger      :: Logger
    }

-- 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/routing-and-handlers
--
-- Note that this is really half the story; in Application.hs, mkYesodDispatch
-- generates the rest of the code. Please see the following documentation
-- for an explanation for this split:
-- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules
--
-- This function also generates the following type synonyms:
-- type Handler = HandlerT App IO
-- type Widget = WidgetT App IO ()
mkYesodData "App" $(parseRoutesFile "config/routes")

-- | A convenient synonym for creating forms.
type Form a = Html -> MForm (HandlerT App IO) (FormResult a, Widget)

type AppDB = YesodDB App

-- 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
    -- Controls the base of generated URLs. For more information on modifying,
    -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
    approot = ApprootRequest $ \app req ->
        case appRoot $ appSettings app of
            Nothing -> getApprootText guessApproot app req
            Just root -> root

    -- Store session data on the client in encrypted cookies,
    -- default session idle timeout is 120 minutes
    makeSessionBackend _ =
        -- sslOnlySessions $
        Just <$>
        defaultClientSessionBackend 120 "config/client_session_key.aes"

    -- Yesod Middleware allows you to run code before and after each handler function.
    -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
    -- The defaultCsrfMiddleware:
    --   a) Sets a cookie with a CSRF token in it.
    --   b) Validates that incoming write requests include that token in either a header or POST parameter.
    -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
    yesodMiddleware =
        -- defaultCsrfMiddleware .
        -- sslOnlyMiddleware 120 .
        defaultYesodMiddleware

    defaultLayout widget = do
        master <- getYesod
        mmsg <- getMessage
        mperson <- maybeAuth
        (title, bcs) <- breadcrumbs

        -- We break up the default layout into two components:
        -- default-layout is the contents of the body tag, and
        -- default-layout-wrapper is the entire page. Since the final
        -- value passed to hamletToRepHtml cannot be a widget, this allows
        -- you to use normal widget features in default-layout.

        pc <- widgetToPageContent $ do
            setTitle $ toHtml $
                T.intercalate " :: " (map snd bcs) <> " :: " <> title
            $(widgetFile "default-layout")
        withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")

    -- The page to be redirected to when authentication is required.
    authRoute _ = Just $ AuthR LoginR

    -- Who can access which pages.
    isAuthorized r w = case (r, w) of
        (GroupsR                   , True) -> personAny
        (GroupNewR                 , _   ) -> personAny
        (GroupMembersR grp         , True) -> groupAdmin grp
        (GroupMemberNewR grp       , _   ) -> groupAdmin grp
        (GroupMemberR grp _memb    , True) -> groupAdmin grp

        (KeysR                     , _   ) -> personAny
        (KeyR _key                 , _   ) -> personAny
        (KeyNewR                   , _   ) -> personAny

        (RepoRolesR shr            , _   ) -> personOrGroupAdmin shr
        (RepoRoleNewR shr          , _   ) -> personOrGroupAdmin shr
        (RepoRoleR shr _rl         , _   ) -> personOrGroupAdmin shr
        (RepoRoleOpsR shr _rl      , _   ) -> personOrGroupAdmin shr
        (RepoRoleOpNewR shr _rl    , _   ) -> personOrGroupAdmin shr

        (ProjectRolesR shr         , _   ) -> personOrGroupAdmin shr
        (ProjectRoleNewR shr       , _   ) -> personOrGroupAdmin shr
        (ProjectRoleR shr _rl      , _   ) -> personOrGroupAdmin shr
        (ProjectRoleOpsR shr _rl   , _   ) -> personOrGroupAdmin shr
        (ProjectRoleOpNewR shr _rl , _   ) -> personOrGroupAdmin shr

        (ReposR shar               , True) -> person shar
        (RepoNewR user             , _   ) -> person user
        (RepoR shar _              , True) -> person shar
        (RepoEditR shr _rp         , _   ) -> person shr
        (RepoDevsR shr _rp         , _   ) -> person shr
        (RepoDevNewR shr _rp       , _   ) -> person shr
        (RepoDevR shr _rp _dev     , _   ) -> person shr

        (ProjectsR shar            , True) -> person shar
        (ProjectNewR user          , _   ) -> person user
        (ProjectR shr _prj         , True) -> person shr
        (ProjectEditR shr _prj     , _   ) -> person shr
        (ProjectDevsR shr _prj     , _   ) -> person shr
        (ProjectDevNewR shr _prj   , _   ) -> person shr
        (ProjectDevR shr _prj _dev , _   ) -> person shr

        (TicketsR shar _           , True) -> person shar
        (TicketNewR _ _            , _   ) -> personAny
        (TicketR user _ _          , True) -> person user
        (TicketEditR user _ _      , _   ) -> person user
        (TicketCloseR user _ _     , _   ) -> person user
        (TicketOpenR user _ _      , _   ) -> person user
        (TicketClaimR s j _        , _   ) -> projOp ProjOpClaimTicket s j
        (TicketUnclaimR s j _      , _   ) -> projOp ProjOpUnclaimTicket s j
        (TicketDiscussionR _ _ _   , True) -> personAny
        (TicketMessageR _ _ _ _    , True) -> personAny
        (TicketTopReplyR _ _ _     , _   ) -> personAny
        (TicketReplyR _ _ _ _      , _   ) -> personAny
        _                                  -> return Authorized
        where
        personAnd
            :: (Entity Person -> Handler AuthResult) -> Handler AuthResult
        personAnd f = do
            mp <- maybeAuth
            case mp of
                Nothing -> return AuthenticationRequired
                Just p  -> f p

        personAny :: Handler AuthResult
        personAny = personAnd $ \ _p -> return Authorized

        person :: ShrIdent -> Handler AuthResult
        person ident = personAnd $ \ (Entity _ p) -> do
            let sid = personIdent p
            sharer <- runDB $ getJust sid
            return $ if ident == sharerIdent sharer
                then Authorized
                else Unauthorized "No access to this operation"

        groupRole :: (GroupRole -> Bool) -> ShrIdent -> Handler AuthResult
        groupRole role grp = personAnd $ \ (Entity pid _p) -> runDB $ do
            Entity sid _s <- getBy404 $ UniqueSharer grp
            Entity gid _g <- getBy404 $ UniqueGroup sid
            mem <- getBy $ UniqueGroupMember pid gid
            let mrole = groupMemberRole . entityVal <$> mem
            return $ case mrole of
                Nothing -> Unauthorized "Not a member of the group"
                Just r  ->
                    if role r
                        then Authorized
                        else Unauthorized "Not the expected group role"

        groupAdmin :: ShrIdent -> Handler AuthResult
        groupAdmin = groupRole (== GRAdmin)

        personOrGroupAdmin :: ShrIdent -> Handler AuthResult
        personOrGroupAdmin shr = personAnd $ \ (Entity vpid _vp) -> runDB $ do
            Entity sid _ <- getBy404 $ UniqueSharer shr
            mep <- getBy $ UniquePersonIdent sid
            case mep of
                Just (Entity pid _p) ->
                    return $ if pid == vpid
                        then Authorized
                        else Unauthorized "Can’t access other people’s roles"
                Nothing -> do
                    meg <- getBy $ UniqueGroup sid
                    case meg of
                        Nothing -> do
                            $logWarn $
                                "Found non-person non-group sharer: " <>
                                shr2text shr
                            return $ error "Zombie sharer"
                        Just (Entity gid _g) -> do
                            mem <- getBy $ UniqueGroupMember vpid gid
                            return $ case mem of
                                Nothing -> Unauthorized "Not a group member"
                                Just (Entity _mid m) ->
                                    if groupMemberRole m == GRAdmin
                                        then Authorized
                                        else Unauthorized "Not a group admin"

        projOp
            :: ProjectOperation -> ShrIdent -> PrjIdent -> Handler AuthResult
        projOp op shr prj = personAnd $ \ (Entity pid _p) -> do
            ma <- runDB $ runMaybeT $ do
                Entity sid _s <- MaybeT $ getBy $ UniqueSharer shr
                Entity jid _j <- MaybeT $ getBy $ UniqueProject prj sid
                Entity _cid c <- MaybeT $ getBy $ UniqueProjectCollab jid pid
                let role = projectCollabRole c
                MaybeT $ getBy $ UniqueProjectAccess role op
            return $ case ma of
                Nothing ->
                    Unauthorized
                    "You need a project role with that operation enabled"
                Just _  -> Authorized

    -- 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 ext mime content = do
        master <- getYesod
        let staticDir = appStaticDir $ appSettings master
        addStaticContentExternal
            discardm
            genFileName
            staticDir
            (StaticR . flip StaticRoute [])
            ext
            mime
            content
      where
        -- Generate a unique filename based on the content itself
        genFileName lbs = "autogen-" ++ base64md5 lbs

    -- What messages should be logged. The following includes all messages when
    -- in development, and warnings and errors in production.
    shouldLog app _source level =
        appShouldLogAll (appSettings app)
            || level == LevelWarn
            || level == LevelError

    makeLogger = return . appLogger

-- How to run database actions.
instance YesodPersist App where
    type YesodPersistBackend App = SqlBackend
    runDB action = do
        master <- getYesod
        runSqlPool action $ appConnPool master
instance YesodPersistRunner App where
    getDBRunner = defaultGetDBRunner appConnPool

instance YesodAuth App where
    type AuthId App = PersonId

    -- Where to send a user after successful login
    loginDest _ = HomeR
    -- Where to send a user after logout
    logoutDest _ = HomeR
    -- Override the above two destinations when a Referer: header is present
    redirectToReferer _ = True

    authenticate creds = do
        let ident = credsIdent creds
        mpid <- runDB $ getBy $ UniquePersonLogin $ credsIdent creds
        return $ case mpid of
            Nothing             -> UserError $ IdentifierNotFound ident
            Just (Entity pid _) -> Authenticated pid

    -- You can add other plugins like BrowserID, email or OAuth here
    authPlugins _ = [authHashDB $ Just . UniquePersonLogin]

    authHttpManager = getHttpManager

instance YesodAuthPersist App

-- 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

-- Useful when writing code that is re-usable outside of the Handler context.
-- An example is background jobs that send email.
-- This can also be useful for writing code that works across multiple Yesod
-- applications.
instance HasHttpManager App where
    getHttpManager = appHttpManager

unsafeHandler :: App -> Handler a -> IO a
unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger

-- Note: Some functionality previously present in the scaffolding has been
-- moved to documentation in the Wiki. Following are some hopefully helpful
-- links:
--
-- https://github.com/yesodweb/yesod/wiki/Sending-email
-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding

instance YesodBreadcrumbs App where
    breadcrumb route = return $ case route of
        StaticR _                        -> ("", Nothing)
        FaviconR                         -> ("", Nothing)
        RobotsR                          -> ("", Nothing)

        HomeR                            -> ("Home", Nothing)
        AuthR _                          -> ("Auth", Nothing)

        SharersR                         -> ("Sharers", Just HomeR)
        SharerR shar                     -> (shr2text shar, Just SharersR)

        PeopleR                          -> ("People", Just HomeR)
        PersonNewR                       -> ("New", Just PeopleR)
        PersonR shar                     -> (shr2text shar, Just PeopleR)

        GroupsR                          -> ("Groups", Just HomeR)
        GroupNewR                        -> ("New", Just GroupsR)
        GroupR shar                      -> (shr2text shar, Just GroupsR)
        GroupMembersR shar               -> ("Members", Just $ GroupR shar)
        GroupMemberNewR shar             -> ("New", Just $ GroupMembersR shar)
        GroupMemberR grp memb            -> ( shr2text memb
                                            , Just $ GroupMembersR grp
                                            )

        KeysR                            -> ("Keys", Just HomeR)
        KeyNewR                          -> ("New", Just KeysR)
        KeyR key                         -> (ky2text key, Just KeysR)

        RepoRolesR shr                   -> ("Repo Roles", Just $ SharerR shr)
        RepoRoleNewR shr                 -> ("New", Just $ RepoRolesR shr)
        RepoRoleR shr rl                 -> (rl2text rl, Just $ RepoRolesR shr)
        RepoRoleOpsR shr rl              -> ( "Operations"
                                            , Just $ RepoRoleR shr rl
                                            )
        RepoRoleOpNewR shr rl            -> ("New", Just $ RepoRoleOpsR shr rl)

        ProjectRolesR shr                -> ( "Project Roles"
                                            , Just $ SharerR shr
                                            )
        ProjectRoleNewR shr              -> ("New", Just $ ProjectRolesR shr)
        ProjectRoleR shr rl              -> ( rl2text rl
                                            , Just $ ProjectRolesR shr
                                            )
        ProjectRoleOpsR shr rl           -> ( "Operations"
                                            , Just $ ProjectRoleR shr rl
                                            )
        ProjectRoleOpNewR shr rl         -> ( "New"
                                            , Just $ ProjectRoleOpsR shr rl
                                            )

        ReposR shar                      -> ("Repos", Just $ PersonR shar)
        RepoNewR shar                    -> ("New", Just $ ReposR shar)
        RepoR shar repo                  -> (rp2text repo, Just $ ReposR shar)
        RepoEditR shr rp                 -> ("Edit", Just $ RepoR shr rp)
        RepoSourceR shar repo []         -> ("Files", Just $ RepoR shar repo)
        RepoSourceR shar repo refdir     -> ( last refdir
                                            , Just $
                                              RepoSourceR shar repo $
                                              init refdir
                                            )
        RepoHeadChangesR shar repo       -> ("Changes", Just $ RepoR shar repo)
        RepoChangesR shar repo ref       -> ( ref
                                            , Just $ RepoHeadChangesR shar repo
                                            )
        RepoDevsR shr rp                 -> ( "Collaboratots"
                                            , Just $ RepoR shr rp
                                            )
        RepoDevNewR shr rp               -> ("New", Just $ RepoDevsR shr rp)
        RepoDevR shr rp dev              -> ( shr2text dev
                                            , Just $ RepoDevsR shr rp
                                            )

        DarcsDownloadR _ _ _             -> ("", Nothing)

        GitRefDiscoverR _ _              -> ("", Nothing)

        ProjectsR shar                   -> ("Projects", Just $ PersonR shar)
        ProjectNewR shar                 -> ("New", Just $ ProjectsR shar)
        ProjectR shar proj               -> ( prj2text proj
                                            , Just $ ProjectsR shar
                                            )
        ProjectEditR shr prj             -> ("Edit", Just $ ProjectR shr prj)
        ProjectDevsR shr prj             -> ( "Collaborators"
                                            , Just $ ProjectR shr prj
                                            )
        ProjectDevNewR shr prj           -> ( "New"
                                            , Just $ ProjectDevsR shr prj
                                            )
        ProjectDevR shr prj dev          -> ( shr2text dev
                                            , Just $ ProjectDevsR shr prj
                                            )

        TicketsR shar proj               -> ( "Tickets"
                                            , Just $ ProjectR shar proj
                                            )
        TicketNewR shar proj             -> ("New", Just $ TicketsR shar proj)
        TicketR shar proj num            -> ( T.pack $ '#' : show num
                                            , Just $ TicketsR shar proj
                                            )
        TicketEditR shar proj num        -> ( "Edit"
                                            , Just $ TicketR shar proj num
                                            )
        TicketCloseR _shar _proj _num    -> ("", Nothing)
        TicketOpenR _shar _proj _num     -> ("", Nothing)
        TicketClaimR _shar _proj _num    -> ("", Nothing)
        TicketUnclaimR _shar _proj _num  -> ("", Nothing)
        TicketDiscussionR shar proj num  -> ( "Discussion"
                                            , Just $ TicketR shar proj num
                                            )
        TicketMessageR shar proj t c     -> ( T.pack $ '#' : show c
                                            , Just $
                                              TicketDiscussionR shar proj t
                                            )
        TicketTopReplyR shar proj num    -> ( "New topic"
                                            , Just $
                                              TicketDiscussionR shar proj num
                                            )
        TicketReplyR shar proj num cnum  -> ( "Reply"
                                            , Just $
                                              TicketMessageR shar proj num cnum
                                            )

        WikiPageR shr prj _page          -> ("Wiki", Just $ ProjectR shr prj)