[start adding authorization checks Jeremy Shaw **20120109041200 Ignore-this: f9481d503a0bfc5a593b7b5822e455f6 ] move ./static/style.css ./static/admin.css hunk ./clckwrks/Clckwrks.hs 9 + , module Clckwrks.Unauthorized hunk ./clckwrks/Clckwrks.hs 30 +import Clckwrks.Unauthorized hunk ./clckwrks/Clckwrks/Admin/Template.hs 28 - + addfile ./clckwrks/Clckwrks/BasicTemplate.hs hunk ./clckwrks/Clckwrks/BasicTemplate.hs 1 +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -F -pgmFtrhsx #-} +module Clckwrks.BasicTemplate (basicTemplate) where + +import Control.Applicative ((<$>)) +import Clckwrks.Monad +import Happstack.Server (Response, toResponse) +import Happstack.Server.HSP.HTML () +import HSP + +basicTemplate :: + ( Functor m + , Monad m + , EmbedAsChild (ClckT url m) headers + , EmbedAsChild (ClckT url m) body + ) => String -> headers -> body -> ClckT url m Response +basicTemplate title headers body = + toResponse <$> (unXMLGenT $ + + + + + + <% title %> + <% headers %> + + +

+ <% body %> +

+ + ) hunk ./clckwrks/Clckwrks/Monad.hs 10 + , getUserId hunk ./clckwrks/Clckwrks/Monad.hs 61 +import Happstack.Auth (AuthState, ProfileState, UserId) +import qualified Happstack.Auth as Auth + +import Happstack.Server (Happstack, ServerMonad(..), FilterMonad(..), WebMonad(..), Response, HasRqData(..), ServerPartT, UnWebT, mapServerPartT) +import Happstack.Server.Internal.Monads (FilterFun) hunk ./clckwrks/Clckwrks/Monad.hs 69 -import Happstack.Server (Happstack, ServerMonad(..), FilterMonad(..), WebMonad(..), Response, HasRqData(..), ServerPartT, UnWebT, mapServerPartT) -import Happstack.Server.Internal.Monads (FilterFun) hunk ./clckwrks/Clckwrks/Monad.hs 227 +instance (Functor m, Monad m) => GetAcidState (ClckT url m) AuthState where + getAcidState = (acidAuth . acidState) <$> get + +instance (Functor m, Monad m) => GetAcidState (ClckT url m) ProfileState where + getAcidState = (acidProfile . acidState) <$> get + hunk ./clckwrks/Clckwrks/Monad.hs 242 +getUserId :: (Happstack m, GetAcidState m AuthState, GetAcidState m ProfileState) => m (Maybe UserId) +getUserId = + do authState <- getAcidState + profileState <- getAcidState + Auth.getUserId authState profileState + hunk ./clckwrks/Clckwrks/ProfileData/API.hs 13 -import Happstack.Auth +import Happstack.Auth (UserId(..)) hunk ./clckwrks/Clckwrks/ProfileData/API.hs 20 - do Acid{..} <- acidState <$> get - getUserId acidAuth acidProfile + do -- Acid{..} <- acidState <$> get + getUserId hunk ./clckwrks/Clckwrks/ProfileData/Acid.hs 8 + , HasRole(..) + , AddRole(..) + , RemoveRole(..) hunk ./clckwrks/Clckwrks/ProfileData/Acid.hs 13 -import Clckwrks.ProfileData.Types (ProfileData(..)) +import Clckwrks.ProfileData.Types (ProfileData(..), Role(..)) hunk ./clckwrks/Clckwrks/ProfileData/Acid.hs 18 -import Data.IxSet (IxSet, (@=), empty, getOne, updateIx) +import Data.IxSet (IxSet, (@=), empty, getOne, insert, updateIx) hunk ./clckwrks/Clckwrks/ProfileData/Acid.hs 20 +import qualified Data.Set as Set hunk ./clckwrks/Clckwrks/ProfileData/Acid.hs 43 +updateProfileData :: ProfileData -> Update ProfileDataState () +updateProfileData pd = + do ps <- get + put $ ps { profileData = updateIx (dataFor pd) pd (profileData ps) } + +modifyProfileData :: (ProfileData -> ProfileData) -> UserId -> Update ProfileDataState () +modifyProfileData fn uid = + do ps@(ProfileDataState {..}) <- get + case getOne $ profileData @= uid of + Nothing -> return () + (Just pd) -> + do let pd' = fn pd + put ps { profileData = updateIx (dataFor pd') pd' profileData } + hunk ./clckwrks/Clckwrks/ProfileData/Acid.hs 67 + +hasRole :: UserId -> Role -> Query ProfileDataState Bool +hasRole uid role = + do mp <- getProfileData uid + case mp of + Nothing -> return False + (Just profile) -> + return (role `Set.member` roles profile) + +addRole :: UserId -> Role -> Update ProfileDataState () +addRole uid role = + modifyProfileData fn uid + where + fn profileData = profileData { roles = Set.insert role (roles profileData) } + +removeRole :: UserId -> Role -> Update ProfileDataState () +removeRole uid role = + modifyProfileData fn uid + where + fn profileData = profileData { roles = Set.delete role (roles profileData) } + hunk ./clckwrks/Clckwrks/ProfileData/Acid.hs 92 + , 'hasRole + , 'addRole + , 'removeRole hunk ./clckwrks/Clckwrks/ProfileData/Route.hs 10 -import Happstack.Auth hunk ./clckwrks/Clckwrks/ProfileData/Route.hs 15 - do Acid{..} <- acidState <$> get - mUserId <- getUserId acidAuth acidProfile + do mUserId <- getUserId hunk ./clckwrks/Clckwrks/ProfileData/Types.hs 17 - = Admin - | Editor + = Administrator hunk ./clckwrks/Clckwrks/Server.hs 5 -import Clckwrks.Admin.Route (routeAdmin) -import Clckwrks.Admin.Template (template) -import Clckwrks.ProfileData.Route (routeProfileData) -import Clckwrks.ProfileData.URL (ProfileDataURL(..)) -import Control.Concurrent.STM (atomically, newTVar) -import Control.Monad.State (get, evalStateT) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Text (Text) -import qualified Data.Text as Text -import Data.String (fromString) -import Happstack.Auth (handleAuthProfile) +import Clckwrks.BasicTemplate (basicTemplate) +import Clckwrks.Admin.Route (routeAdmin) +import Clckwrks.ProfileData.Acid (HasRole(..)) +import Clckwrks.ProfileData.Route (routeProfileData) +import Clckwrks.ProfileData.Types (Role(..)) +import Clckwrks.ProfileData.URL (ProfileDataURL(..)) +import Control.Concurrent.STM (atomically, newTVar) +import Control.Monad.State (get, evalStateT) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Data.String (fromString) +import Happstack.Auth (handleAuthProfile) hunk ./clckwrks/Clckwrks/Server.hs 20 -import System.FilePath ((), makeRelative, splitDirectories) -import Web.Routes.Happstack (implSite) +import System.FilePath ((), makeRelative, splitDirectories) +import Web.Routes.Happstack (implSite) hunk ./clckwrks/Clckwrks/Server.hs 74 +requiresRole :: (Happstack m) => Role -> url -> ClckT ClckURL m url +requiresRole role url = + do mu <- getUserId + case mu of + Nothing -> escape $ seeOtherURL (Auth $ AuthURL A_Login) + (Just uid) -> + do r <- query (HasRole uid role) + if r + then return url + else escape $ unauthorizedPage "You do not have permission to view this page." + +checkAuth :: (Happstack m, Monad m) => ClckURL -> ClckT ClckURL m ClckURL +checkAuth url = + case url of + ViewPage{} -> return url + ThemeData{} -> return url + PluginData{} -> return url + Admin{} -> requiresRole Administrator url + Profile{} -> return url + Auth{} -> return url + hunk ./clckwrks/Clckwrks/Server.hs 96 -routeClck pageHandler url = - do setUnique 0 +routeClck pageHandler url' = + do url <- checkAuth url' + setUnique 0 hunk ./clckwrks/Clckwrks/Server.hs 125 - nestURL Auth $ handleAuthProfile acidAuth acidProfile template Nothing Nothing u apURL + nestURL Auth $ handleAuthProfile acidAuth acidProfile basicTemplate Nothing Nothing u apURL hunk ./clckwrks/Clckwrks/Server.hs 135 - addfile ./clckwrks/Clckwrks/Unauthorized.hs hunk ./clckwrks/Clckwrks/Unauthorized.hs 1 +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -F -pgmFtrhsx #-} +module Clckwrks.Unauthorized + ( unauthorizedPage + ) where + +import Control.Applicative ((<$>)) +import HSP +import Happstack.Server (Happstack, Response, ToMessage, toResponse, unauthorized) +import qualified HSX.XMLGenerator as HSX + +unauthorizedPage :: + ( Happstack m + , XMLGenerator m + , EmbedAsChild m msg + , ToMessage (HSX.XML m) + ) => msg -> m Response +unauthorizedPage msg = + do unauthorized () + toResponse <$> (unXMLGenT $ + + + Unauthorized + + +

Unauthorized

<% msg %>

+ + ) hunk ./clckwrks/clckwrks.cabal 32 + Clckwrks.BasicTemplate hunk ./clckwrks/clckwrks.cabal 52 + Clckwrks.Unauthorized hunk ./clckwrks/clckwrks.cabal 58 - aeson == 0.4.*, + aeson == 0.5.*, hunk ./clckwrks/clckwrks.cabal 60 - base < 4.4, + base < 5, hunk ./clckwrks/clckwrks.cabal 67 - filepath == 1.2.*, + filepath >= 1.2 && <1.4, hunk ./clckwrks/clckwrks.cabal 78 - process == 1.0.*, + process >= 1.0 && < 1.2, hunk ./clckwrks/clckwrks.cabal 84 - time == 1.2.*, + time >= 1.2 && <1.5, addfile ./static/style.css hunk ./static/style.css 1 +body +{ + margin: 0; + padding: 0; +}