clckwrks 0.16.2 → 0.18.0
raw patch · 16 files changed
+148/−287 lines, 16 filesdep −hsxdep ~acid-statedep ~happstack-hspdep ~happstack-server
Dependencies removed: hsx
Dependency ranges changed: acid-state, happstack-hsp, happstack-server, hsp, hsx-jmacro, reform, reform-happstack, reform-hsp
Files
- Clckwrks.hs +0/−6
- Clckwrks/Acid.hs +2/−2
- Clckwrks/Admin/Console.hs +5/−2
- Clckwrks/Admin/EditSettings.hs +9/−6
- Clckwrks/Admin/Template.hs +5/−2
- Clckwrks/BasicTemplate.hs +7/−6
- Clckwrks/Monad.hs +39/−34
- Clckwrks/NavBar/API.hs +5/−1
- Clckwrks/NavBar/EditNavBar.hs +7/−5
- Clckwrks/ProfileData/EditProfileData.hs +13/−9
- Clckwrks/ProfileData/EditProfileDataFor.hs +8/−6
- Clckwrks/Route.hs +14/−1
- Clckwrks/URL.hs +17/−35
- Clckwrks/Unauthorized.hs +7/−4
- HSP/HTMLBuilder.hs +0/−156
- clckwrks.cabal +10/−12
Clckwrks.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, TypeFamilies #-} module Clckwrks ( module Clckwrks.Acid--- , module Clckwrks.Menu.API , module Clckwrks.Monad , module Clckwrks.ProfileData.API , module Clckwrks.ProfileData.Types@@ -12,8 +11,6 @@ , module Control.Monad , module Control.Monad.Trans , module Happstack.Auth- , module HSP- , module HSP.ServerPartT , module Happstack.Server , module Language.Javascript.JMacro , module Web.Routes@@ -22,7 +19,6 @@ import Clckwrks.Acid import Clckwrks.Admin.URL--- import Clckwrks.Menu.API import Clckwrks.Monad import Clckwrks.ProfileData.API import Clckwrks.ProfileData.Types@@ -35,8 +31,6 @@ import Happstack.Auth (UserId(..)) import Happstack.Server import Happstack.Server.HSP.HTML-import HSP hiding (Request, escape)-import HSP.ServerPartT import Language.Javascript.JMacro (JExpr(..), JMacro(..), JStat(..), JType(..), JVal(..), Ident(..), toJExpr, jmacro, jmacroE) import Web.Routes hiding (nestURL) import Web.Routes.XMLGenT ()
Clckwrks/Acid.hs view
@@ -12,7 +12,7 @@ import Control.Monad.State (modify) import Data.Acid (AcidState, Query, Update, makeAcidic) import Data.Acid.Local (openLocalStateFrom, createArchive, createCheckpointAndClose)-import Data.Acid.Remote (acidServer)+import Data.Acid.Remote (acidServer, skipAuthenticationCheck) import Data.Data (Data, Typeable) import Data.Maybe (fromMaybe) import Data.SafeCopy (base, deriveSafeCopy)@@ -84,7 +84,7 @@ bracket (openLocalStateFrom (basePath </> "profileData") initialProfileDataState) (createArchiveCheckpointAndClose) $ \profileData -> bracket (openLocalStateFrom (basePath </> "core") initialCoreState) (createArchiveCheckpointAndClose) $ \core -> bracket (openLocalStateFrom (basePath </> "navBar") initialNavBarState) (createArchiveCheckpointAndClose) $ \navBar ->- bracket (forkIO (tryRemoveFile (basePath </> "profileData_socket") >> acidServer profileData (UnixSocket $ basePath </> "profileData_socket")))+ bracket (forkIO (tryRemoveFile (basePath </> "profileData_socket") >> acidServer skipAuthenticationCheck (UnixSocket $ basePath </> "profileData_socket") profileData)) (\tid -> killThread tid >> tryRemoveFile (basePath </> "profileData_socket")) (const $ f (Acid auth profile profileData core navBar)) where
Clckwrks/Admin/Console.hs view
@@ -1,9 +1,12 @@-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Admin.Console where import Clckwrks (AdminURL(..), Clck, Response) import Clckwrks.Admin.Template (template)-import HSP+import Data.Text.Lazy (Text)+import HSP.XMLGenerator+import HSP.XML consolePage :: Clck AdminURL Response consolePage =
Clckwrks/Admin/EditSettings.hs view
@@ -1,12 +1,15 @@-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Admin.EditSettings where import Clckwrks import Clckwrks.Acid (GetUACCT(..), SetUACCT(..))-import Clckwrks.Admin.Template (template)+import Clckwrks.Admin.Template (template)+import Data.Text.Lazy (Text) -- import Clckwrks.Page.Acid (GetUACCT(..), SetUACCT(..))-import HSP.Google.Analytics (UACCT(..))+import HSP.Google.Analytics (UACCT(..))+import HSP.XMLGenerator+import HSP.XML (fromStringLit) import Text.Reform import Text.Reform.Happstack import Text.Reform.HSP.String@@ -30,9 +33,9 @@ divHorizontal $ fieldset $ (divControlGroup $- (label "Google Analytics UACCT" `setAttrs` [("class":="control-label")]) ++>+ (label ("Google Analytics UACCT" :: Text) `setAttrs` [("class":="control-label") :: Attr Text Text]) ++> (divControls (inputText (unUACCT muacct)) `transformEither` toMUACCT)) <*- (divControlGroup $ divControls $ inputSubmit "Update" `setAttrs` [("class" := "btn")])+ (divControlGroup $ divControls $ inputSubmit "Update" `setAttrs` [("class" := "btn") :: Attr Text Text]) where divHorizontal = mapView (\xml -> [<div class="form-horizontal"><% xml %></div>]) divControlGroup = mapView (\xml -> [<div class="control-group"><% xml %></div>])
Clckwrks/Admin/Template.hs view
@@ -1,13 +1,16 @@-{-# LANGUAGE FlexibleContexts #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Admin.Template where import Clckwrks import Control.Monad.State (get) import Data.Maybe (mapMaybe)+import Data.Text.Lazy (Text) import qualified Data.Text as T import Data.Set (Set) import qualified Data.Set as Set+import HSP.XMLGenerator+import HSP.XML (XML, fromStringLit) template ::
Clckwrks/BasicTemplate.hs view
@@ -1,19 +1,20 @@-{-# LANGUAGE FlexibleContexts #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.BasicTemplate (basicTemplate) where import Control.Applicative ((<$>)) import Clckwrks.Monad+import Data.Text.Lazy (Text) import Happstack.Server (Response, toResponse)-import Happstack.Server.HSP.HTML ()-import HSP+import HSP.XMLGenerator+import HSP.XML -basicTemplate :: +basicTemplate :: ( Functor m , Monad m , EmbedAsChild (ClckT url m) headers , EmbedAsChild (ClckT url m) body- ) => String -> headers -> body -> ClckT url m Response+ ) => Text -> headers -> body -> ClckT url m Response basicTemplate title headers body = toResponse <$> (unXMLGenT $ <html>
Clckwrks/Monad.hs view
@@ -47,6 +47,8 @@ , withAbs' , segments , transform+ , module HSP.XML+ , module HSP.XMLGenerator ) where @@ -94,17 +96,19 @@ import Happstack.Server (Happstack, ServerMonad(..), FilterMonad(..), WebMonad(..), Input, Request(..), Response, HasRqData(..), ServerPartT, UnWebT, internalServerError, mapServerPartT, escape, toResponse) import Happstack.Server.HSP.HTML () -- ToMessage XML instance+import Happstack.Server.XMLGenT () -- instance Happstack XMLGenT import Happstack.Server.Internal.Monads (FilterFun)-import HSP hiding (Request, escape)+-- import HSP hiding (Request, escape) import HSP.Google.Analytics (UACCT, analyticsAsync)-import HSP.ServerPartT ()-import HSX.XMLGenerator (XMLGen(..))-import HSX.JMacro (IntegerSupply(..))+-- import HSP.ServerPartT ()+import HSP.XML hiding (Name)+import HSP.XMLGenerator+import HSP.JMacro (IntegerSupply(..)) import Language.Javascript.JMacro import Prelude hiding (takeWhile) import System.Locale (defaultTimeLocale) import Text.Blaze.Html (Html)-import Text.Blaze.Html.Renderer.String (renderHtml)+import Text.Blaze.Html.Renderer.Text (renderHtml) import Text.Reform (CommonFormError, Form, FormError(..)) import Web.Routes (URL, MonadRoute(askRouteFn), RouteT(RouteT, unRouteT), mapRouteT, showURL, withRouteT) import Web.Plugins.Core (Plugins, getConfig, getPluginsSt, modifyPluginsSt, getTheme)@@ -362,6 +366,7 @@ instance (Functor m, Monad m) => XMLGen (ClckT url m) where type XMLType (ClckT url m) = XML+ type StringType (ClckT url m) = TL.Text newtype ChildType (ClckT url m) = ClckChild { unClckChild :: XML } newtype AttributeType (ClckT url m) = ClckAttr { unClckAttr :: Attribute } genElement n attrs children =@@ -386,67 +391,67 @@ flP [] bs = reverse bs flP [x] bs = reverse (x:bs) flP (x:y:xs) bs = case (x,y) of- (CDATA e1 s1, CDATA e2 s2) | e1 == e2 -> flP (CDATA e1 (s1++s2) : xs) bs+ (CDATA e1 s1, CDATA e2 s2) | e1 == e2 -> flP (CDATA e1 (s1<>s2) : xs) bs _ -> flP (y:xs) (x:bs)-+{- instance (Functor m, Monad m) => IsAttrValue (ClckT url m) T.Text where toAttrValue = toAttrValue . T.unpack instance (Functor m, Monad m) => IsAttrValue (ClckT url m) TL.Text where toAttrValue = toAttrValue . TL.unpack-+-} instance (Functor m, Monad m) => EmbedAsAttr (ClckT url m) Attribute where asAttr = return . (:[]) . ClckAttr -instance (Functor m, Monad m, IsName n) => EmbedAsAttr (ClckT url m) (Attr n String) where- asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal str)+instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ClckT url m) (Attr n String) where+ asAttr (n := str) = asAttr $ MkAttr (toName n, pAttrVal $ TL.pack str) -instance (Functor m, Monad m, IsName n) => EmbedAsAttr (ClckT url m) (Attr n Char) where- asAttr (n := c) = asAttr (n := [c])+instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ClckT url m) (Attr n Char) where+ asAttr (n := c) = asAttr (n := TL.singleton c) -instance (Functor m, Monad m, IsName n) => EmbedAsAttr (ClckT url m) (Attr n Bool) where+instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ClckT url m) (Attr n Bool) where asAttr (n := True) = asAttr $ MkAttr (toName n, pAttrVal "true") asAttr (n := False) = asAttr $ MkAttr (toName n, pAttrVal "false") -instance (Functor m, Monad m, IsName n) => EmbedAsAttr (ClckT url m) (Attr n Int) where- asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i))+instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ClckT url m) (Attr n Int) where+ asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal $ TL.pack (show i)) -instance (Functor m, Monad m, IsName n) => EmbedAsAttr (ClckT url m) (Attr n Integer) where- asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal (show i))+instance (Functor m, Monad m, IsName n TL.Text) => EmbedAsAttr (ClckT url m) (Attr n Integer) where+ asAttr (n := i) = asAttr $ MkAttr (toName n, pAttrVal $ TL.pack (show i)) -instance (IsName n) => EmbedAsAttr (Clck ClckURL) (Attr n ClckURL) where+instance (IsName n TL.Text) => EmbedAsAttr (Clck ClckURL) (Attr n ClckURL) where asAttr (n := u) = do url <- showURL u- asAttr $ MkAttr (toName n, pAttrVal (T.unpack url))+ asAttr $ MkAttr (toName n, pAttrVal $ TL.fromStrict url) -instance (IsName n) => EmbedAsAttr (Clck AdminURL) (Attr n AdminURL) where+instance (IsName n TL.Text) => EmbedAsAttr (Clck AdminURL) (Attr n AdminURL) where asAttr (n := u) = do url <- showURL u- asAttr $ MkAttr (toName n, pAttrVal (T.unpack url))+ asAttr $ MkAttr (toName n, pAttrVal (TL.fromStrict url)) -instance (Functor m, Monad m, IsName n) => (EmbedAsAttr (ClckT url m) (Attr n TL.Text)) where- asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ TL.unpack a)+instance (Functor m, Monad m, IsName n TL.Text) => (EmbedAsAttr (ClckT url m) (Attr n TL.Text)) where+ asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ a) -instance (Functor m, Monad m, IsName n) => (EmbedAsAttr (ClckT url m) (Attr n T.Text)) where- asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ T.unpack a)+instance (Functor m, Monad m, IsName n TL.Text) => (EmbedAsAttr (ClckT url m) (Attr n T.Text)) where+ asAttr (n := a) = asAttr $ MkAttr (toName n, pAttrVal $ TL.fromStrict a) instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Char where- asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . (:[])+ asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . TL.singleton instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) String where- asChild = XMLGenT . return . (:[]) . ClckChild . pcdata+ asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . TL.pack instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Int where- asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . show+ asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . TL.pack . show instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Integer where- asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . show+ asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . TL.pack . show instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Double where- asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . show+ asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . TL.pack . show instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Float where- asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . show+ asChild = XMLGenT . return . (:[]) . ClckChild . pcdata . TL.pack . show instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) TL.Text where asChild = asChild . TL.unpack@@ -511,8 +516,8 @@ deriving (Eq, Ord, Read, Show, Data, Typeable) instance (Functor m, Monad m) => EmbedAsChild (ClckT url m) Content where- asChild (TrustedHtml html) = asChild $ cdata (T.unpack html)- asChild (PlainText txt) = asChild $ pcdata (T.unpack txt)+ asChild (TrustedHtml html) = asChild $ cdata (TL.fromStrict html)+ asChild (PlainText txt) = asChild $ pcdata (TL.fromStrict txt) addPreProc :: (MonadIO m) => Plugins theme n hook config ClckPluginsSt@@ -585,7 +590,7 @@ do r <- query (HasRole uid role) if r then return url- else escape $ unauthorizedPage ("You do not have permission to view this page." :: T.Text)+ else escape $ unauthorizedPage ("You do not have permission to view this page.") getUserRoles :: (Happstack m, MonadIO m) => ClckT u m (Set Role) getUserRoles =
@@ -1,9 +1,13 @@-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.NavBar.API where import Clckwrks import Clckwrks.NavBar.Acid import Clckwrks.NavBar.Types+import Data.Text.Lazy (Text)+import HSP.XMLGenerator+import HSP.XML getNavBarData :: (Functor m, MonadIO m) => ClckT url m NavBar getNavBarData = query GetNavBar
@@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleInstances, OverloadedStrings, QuasiQuotes, RecordWildCards #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.NavBar.EditNavBar where import Clckwrks.Admin.Template (template)@@ -13,11 +13,13 @@ import Control.Monad.State (get) import Control.Monad.Trans (lift, liftIO) import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), (.:), (.=), decode, object)-import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Lazy (Text) import Data.Tree (Tree(..)) import qualified Data.Vector as Vector import Happstack.Server (Response, internalServerError, lookBS, ok, toResponse)-import HSP+import HSP.XML (fromStringLit)+import HSP.XMLGenerator import Language.Javascript.JMacro import Web.Routes (showURL) @@ -149,7 +151,7 @@ |] -saveChanges :: Text -> JStat+saveChanges :: T.Text -> JStat saveChanges navBarUpdateURL = [$jmacro| $("#saveChanges").click(function () {@@ -227,7 +229,7 @@ -- liftIO $ print mu case mu of Nothing ->- do internalServerError $ toResponse ("navBarPost: failed to decode JSON data" :: Text)+ do internalServerError $ toResponse ("navBarPost: failed to decode JSON data" :: T.Text) (Just (NavBarUpdate u)) -> do update (SetNavBar u) ok $ toResponse ()
Clckwrks/ProfileData/EditProfileData.hs view
@@ -1,17 +1,20 @@-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.ProfileData.EditProfileData where import Clckwrks import Clckwrks.Admin.Template (template) import Clckwrks.ProfileData.Acid (GetProfileData(..), SetProfileData(..), profileDataErrorStr)-import Data.Text (Text, pack)-import Data.Maybe (fromMaybe)+import Data.Text (pack) import qualified Data.Text as Text+import Data.Text.Lazy (Text)+import Data.Maybe (fromMaybe) import Happstack.Auth (UserId) import Text.Reform ((++>), mapView, transformEitherM)-import Text.Reform.HSP.Text (form, inputText, inputSubmit, label, fieldset, ol, li, errorList, setAttrs)+import Text.Reform.HSP.Text (form, inputText, inputSubmit, labelText, fieldset, ol, li, errorList, setAttrs) import Text.Reform.Happstack (reform)+import HSP.XMLGenerator+import HSP.XML -- FIXME: this currently uses the admin template. Which is sort of right, and sort of not. @@ -19,12 +22,13 @@ editProfileDataPage here = do mUid <- getUserId case mUid of- Nothing -> internalServerError $ toResponse $ "Unable to retrieve your userid"+ Nothing -> internalServerError $ toResponse $ ("Unable to retrieve your userid" :: Text) (Just uid) -> do mpd <- query (GetProfileData uid) case mpd of Nothing -> internalServerError $ toResponse $ "Missing profile data for " ++ show uid+ (Just pd) -> do action <- showURL here template "Edit Profile Data" () $@@ -42,15 +46,15 @@ errorList ++> ((,) <$> (divControlGroup (label' "Username" ++> (divControls (inputText username)))) <*> (divControlGroup (label'" Email (optional)" ++> (divControls (inputText (fromMaybe Text.empty email)))))- <* (divControlGroup (divControls (inputSubmit (pack "Update") `setAttrs` ("class" := "btn")))))+ <* (divControlGroup (divControls (inputSubmit (pack "Update") `setAttrs` (("class" := "btn") :: Attr Text Text))))) `transformEitherM` updateProfileData where- label' str = (label str `setAttrs` [("class":="control-label")])+ label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text]) divHorizontal = mapView (\xml -> [<div class="form-horizontal"><% xml %></div>]) divControlGroup = mapView (\xml -> [<div class="control-group"><% xml %></div>]) divControls = mapView (\xml -> [<div class="controls"><% xml %></div>]) - updateProfileData :: (Text, Text) -> Clck ProfileDataURL (Either ClckFormError ())+ updateProfileData :: (Text.Text, Text.Text) -> Clck ProfileDataURL (Either ClckFormError ()) updateProfileData (usrnm, eml) = do let newPd = pd { username = usrnm , email = if Text.null eml then Nothing else (Just eml)
Clckwrks/ProfileData/EditProfileDataFor.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE RecordWildCards, OverloadedStrings #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.ProfileData.EditProfileDataFor where import Clckwrks@@ -10,9 +10,11 @@ import Data.Text (Text, pack) import qualified Data.Text as Text import Happstack.Auth (UserId)+import HSP.XMLGenerator+import HSP.XML import Text.Reform ((++>), transformEitherM) import Text.Reform.Happstack (reform)-import Text.Reform.HSP.Text (inputCheckboxes, inputText, label, inputSubmit, fieldset, ol, li, form)+import Text.Reform.HSP.Text (inputCheckboxes, inputText, labelText, inputSubmit, fieldset, ol, li, form) editProfileDataForPage :: ProfileDataURL -> UserId -> Clck ProfileDataURL Response editProfileDataForPage here uid =@@ -36,9 +38,9 @@ profileDataFormlet pd@ProfileData{..} = (fieldset $ ol $- ((,,) <$> (li $ label "username:") ++> (li $ inputText username)- <*> (li $ label "email (optional):") ++> (li $ inputText (fromMaybe Text.empty email))- <*> (li $ label "roles:") ++> (li $ inputCheckboxes [ (r, show r) | r <- [minBound .. maxBound]] (\r -> Set.member r roles))+ ((,,) <$> (li $ labelText "username:") ++> (li $ inputText username)+ <*> (li $ labelText "email (optional):") ++> (li $ inputText (fromMaybe Text.empty email))+ <*> (li $ labelText "roles:") ++> (li $ inputCheckboxes [ (r, show r) | r <- [minBound .. maxBound]] (\r -> Set.member r roles)) <* inputSubmit (pack "update") ) ) `transformEitherM` updateProfileData
Clckwrks/Route.hs view
@@ -25,6 +25,7 @@ checkAuth url = case url of ThemeData{} -> return url+ ThemeDataNoEscape{} -> return url PluginData{} -> return url Admin{} -> requiresRole (Set.singleton Administrator) url Auth{} -> return url@@ -48,7 +49,19 @@ let fp'' = makeRelative "/" (unEscapeString fp') if not (isSafePath (splitDirectories fp'')) then notFound (toResponse ())- else serveFile (guessContentTypeM mimeTypes) (fp </> "data" </> fp'')+ else serveFile (guessContentTypeM mimeTypes) (fp </> fp'')++ (ThemeDataNoEscape (NoEscape fp')) ->+ do p <- plugins <$> get+ mTheme <- getTheme p+ case mTheme of+ Nothing -> notFound $ toResponse ("No theme package is loaded." :: Text)+ (Just theme) ->+ do fp <- liftIO $ themeDataDir theme+ let fp'' = makeRelative "/" fp'+ if not (isSafePath (splitDirectories fp''))+ then notFound (toResponse ())+ else serveFile (guessContentTypeM mimeTypes) (fp </> fp'') (PluginData plugin fp') -> do pp <- liftIO getDataDir
Clckwrks/URL.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TemplateHaskell, TypeFamilies #-} module Clckwrks.URL ( ClckURL(..) , AdminURL(..)@@ -6,58 +6,40 @@ , ProfileURL(..) , AuthProfileURL(..) , ProfileDataURL(..)+ , NoEscape(..) ) where import Clckwrks.Admin.URL (AdminURL(..)) -- import Clckwrks.Page.Acid (PageId(..)) -- import Clckwrks.Page.Types (Slug(..)) import Clckwrks.ProfileData.URL (ProfileDataURL(..))-import Control.Applicative ((<$>))+import Control.Applicative ((<$>), many) import Data.Data (Data, Typeable) import Data.SafeCopy (Migrate(..), SafeCopy(..), base, deriveSafeCopy, extension)-import Data.Text (Text)+import Data.Text (Text, pack, unpack) import Happstack.Auth (AuthURL(..), ProfileURL(..), AuthProfileURL(..), UserId) import Happstack.Auth.Core.AuthURL (OpenIdURL, AuthMode, OpenIdProvider)+import System.FilePath (joinPath, splitDirectories)+import Web.Routes (PathInfo(..), anySegment) import Web.Routes.TH (derivePathInfo)-{--data ClckURL_1- = ViewPage_1 PageId- | Blog_1- | AtomFeed_1- | ThemeData_1 FilePath- | PluginData_1 Text FilePath- | Admin_1 AdminURL- | Profile_1 ProfileDataURL- | Auth_1 AuthProfileURL++newtype NoEscape a = NoEscape a deriving (Eq, Ord, Data, Typeable, Read, Show)-$(deriveSafeCopy 1 'base ''ClckURL_1)--}++instance PathInfo (NoEscape String) where+ toPathSegments (NoEscape s) = map pack $ splitDirectories s+ fromPathSegments =+ do ps <- many anySegment+ return (NoEscape (joinPath $ map unpack ps))+ data ClckURL-{-- = ViewPage PageId- | ViewPageSlug PageId Slug- | Blog- | AtomFeed--}- = ThemeData FilePath+ = ThemeData String+ | ThemeDataNoEscape (NoEscape FilePath) | PluginData Text FilePath | Admin AdminURL | Profile ProfileDataURL | Auth AuthProfileURL deriving (Eq, Ord, Data, Typeable, Read, Show)-(deriveSafeCopy 3 'base ''ClckURL)-{--instance Migrate ClckURL where- type MigrateFrom ClckURL = ClckURL_1- migrate (ViewPage_1 pid) = ViewPage pid- migrate Blog_1 = Blog- migrate AtomFeed_1 = AtomFeed- migrate (ThemeData_1 fp) = ThemeData fp- migrate (PluginData_1 t f) = PluginData t f- migrate (Admin_1 u) = Admin u- migrate (Profile_1 pdu) = Profile pdu- migrate (Auth_1 apu) = Auth apu--} -- TODO: move upstream $(deriveSafeCopy 1 'base ''AuthURL)
Clckwrks/Unauthorized.hs view
@@ -1,17 +1,20 @@-{-# LANGUAGE FlexibleContexts #-}-{-# OPTIONS_GHC -F -pgmFtrhsx #-}+{-# LANGUAGE FlexibleContexts, OverloadedStrings, TypeFamilies #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Unauthorized ( unauthorizedPage ) where import Control.Applicative ((<$>))-import HSP+-- import HSP+import Data.Text.Lazy import Happstack.Server (Happstack, Response, ToMessage, toResponse, unauthorized)-import qualified HSX.XMLGenerator (XMLType)+import HSP.XML+import HSP.XMLGenerator unauthorizedPage :: ( Happstack m , XMLGenerator m+ , StringType m ~ Text , EmbedAsChild m msg , ToMessage (XMLType m) ) => msg -> m Response
− HSP/HTMLBuilder.hs
@@ -1,156 +0,0 @@--------------------------------------------------------------------------------- |--- Module : HSP.HTML--- Copyright : (c) Niklas Broberg, Jeremy Shaw 2008--- License : BSD-style (see the file LICENSE.txt)------ Maintainer : Niklas Broberg, nibro@cs.chalmers.se--- Stability : experimental--- Portability : Haskell 98------ Attempt to render XHTML as well-formed HTML 4.01:------ 1. no short tags are used, e.g., \<script\>\<\/script\> instead of \<script \/\>------ 2. the end tag is forbidden for some elements, for these we:------ * render only the open tag, e.g., \<br\>------ * throw an error if the tag contains children------ 3. optional end tags are always rendered------ Currently no validation is performed.-------------------------------------------------------------------------------module HSP.HTMLBuilder (- Style(..)- -- * Functions- , renderAsHTML- , htmlEscapeChars- ) where--import Data.List-import Data.Monoid (mappend, mconcat, mempty)-import Data.Text.Lazy (unpack)-import Data.Text.Lazy.Builder (Builder, fromString, singleton, toLazyText)-import HSP.XML-import HSP.XML.PCDATA(escaper)---- | Pretty-prints HTML values.------ Error Handling:------ Some tags (such as img) can not contain children in HTML. However,--- there is nothing to stop the caller from passing in XML which--- contains an img tag with children. There are three basic ways to--- handle this:------ 1. drop the bogus children silently------ 2. call 'error' \/ raise an exception------ 3. render the img tag with children -- even though it is invalid------ Currently we are taking approach #3, since no other attempts to--- validate the data are made in this function. Instead, you can run--- the output through a full HTML validator to detect the errors.------ #1 seems like a poor choice, since it makes is easy to overlook the--- fact that data went missing.------ We could raising errors, but you have to be in the IO monad to--- catch them. Also, you have to use evaluate if you want to check for--- errors. This means you can not start sending the page until the--- whole page has been rendered. And you have to store the whole page--- in RAM at once. Similar problems occur if we return Either--- instead. We mostly care about catching errors and showing them in--- the browser during testing, so perhaps this can be configurable.------ Another solution would be a compile time error if an empty-only--- tag contained children.------ FIXME: also verify that the domain is correct------ FIXME: what to do if a namespace is encountered--renderAsHTML :: Style -> XML -> Builder-renderAsHTML style xml = renderAsHTML' style 0 xml--data TagType = Open | Close--data Style = Compact | Expanded--renderAsHTML' :: Style -> Int -> XML -> Builder-renderAsHTML' _ _ (CDATA needsEscape cd) = fromString (if needsEscape then (escaper htmlEscapeChars cd) else cd)--renderAsHTML' style n elm@(Element name@(Nothing,nm) attrs children)- | nm == "area" = renderTagEmpty children- | nm == "base" = renderTagEmpty children- | nm == "br" = renderTagEmpty children- | nm == "col" = renderTagEmpty children- | nm == "hr" = renderTagEmpty children- | nm == "img" = renderTagEmpty children- | nm == "input" = renderTagEmpty children- | nm == "link" = renderTagEmpty children- | nm == "meta" = renderTagEmpty children- | nm == "param" = renderTagEmpty children- | nm == "script" = renderElement style n (Element name attrs (map asCDATA children))- | nm == "style" = renderElement style n (Element name attrs (map asCDATA children))- where- renderTagEmpty [] = renderTag style Open n name attrs- renderTagEmpty _ = renderElement style n elm -- this case should not happen in valid HTML- -- for and script\/style, render text in element as CDATA not PCDATA- asCDATA :: XML -> XML- asCDATA (CDATA _ cd) = (CDATA False cd)- asCDATA o = o -- this case should not happen in valid HTML-renderAsHTML' style n e = renderElement style n e--renderElement :: Style -> Int -> XML -> Builder-renderElement style n (Element name attrs children) =- let open = renderTag style Open n name attrs- cs = renderChildren n children- close = renderTag style Close n name []- in mconcat [open, cs, close]- where renderChildren :: Int -> Children -> Builder- renderChildren n' cs = mconcat $ map (renderAsHTML' style (n'+2)) cs-renderElement _ _ _ = error "internal error: renderElement only suports the Element constructor."---renderTag :: Style -> TagType -> Int -> Name -> Attributes -> Builder-renderTag style typ n name attrs =- let (start,end) = case typ of- Open -> (singleton '<' , singleton '>')- Close -> (fromString "</", singleton '>')- nam = showName name- as = renderAttrs attrs- in mconcat [start, nam, as, end]-- where renderAttrs :: Attributes -> Builder- renderAttrs [] = nl- renderAttrs attrs' = mconcat [singleton ' ', ats, nl]- where ats = mconcat $ intersperse (singleton ' ') $ fmap renderAttr attrs'-- renderAttr :: Attribute -> Builder- renderAttr (MkAttr (nam, (Value needsEscape val))) =- mconcat [ showName nam, singleton '=', renderAttrVal (if needsEscape then (escaper htmlEscapeChars val) else val)]-- renderAttrVal :: String -> Builder- renderAttrVal s =- mconcat [singleton '\"', fromString s, singleton '\"']-- showName (Nothing, s) = fromString s- showName (Just d, s) = mconcat [fromString d, singleton ':', fromString s]-- nl =- case style of- Compact -> mempty- Expanded -> singleton '\n' `mappend` (fromString $ replicate n ' ')---- This list should be extended.-htmlEscapeChars :: [(Char, String)]-htmlEscapeChars = [- ('&', "amp" ),- ('\"', "quot" ),- ('<', "lt" ),- ('>', "gt" )- ]
clckwrks.cabal view
@@ -1,5 +1,5 @@ Name: clckwrks-Version: 0.16.2+Version: 0.18.0 Synopsis: A secure, reliable content management system (CMS) and blogging platform Description: clckwrks (pronounced, clockworks) aims to compete directly with popular PHP-based blogging and CMS@@ -61,11 +61,10 @@ Clckwrks.Types Clckwrks.Unauthorized Clckwrks.URL- HSP.HTMLBuilder Paths_clckwrks Build-depends:- acid-state >= 0.7 && < 0.9,+ acid-state >= 0.11 && < 0.12, aeson >= 0.5 && < 0.7, attoparsec == 0.10.*, base < 5,@@ -75,12 +74,11 @@ directory >= 1.1 && < 1.3, filepath >= 1.2 && < 1.4, happstack-authenticate == 0.10.*,- happstack-hsp == 7.1.*,- happstack-server >= 7.0 && < 7.2,+ happstack-hsp == 7.2.*,+ happstack-server >= 7.0 && < 7.4, happstack-server-tls >= 7.0 && < 7.2,- hsp == 0.7.*,- hsx == 0.10.*,- hsx-jmacro == 7.2.*,+ hsp == 0.9.*,+ hsx-jmacro == 7.3.*, ixset == 1.0.*, jmacro == 0.6.*, mtl >= 2.0 && < 2.3,@@ -89,9 +87,9 @@ process >= 1.0 && < 1.2, -- plugins-auto == 0.0.1.1, random == 1.0.*,- reform == 0.1.*,- reform-happstack == 0.1.*,- reform-hsp >= 0.1.1 && < 0.2,+ reform == 0.2.*,+ reform-happstack == 0.2.*,+ reform-hsp >= 0.2 && < 0.3, safecopy >= 0.6, stm >= 2.2 && <2.5, tagsoup == 0.12.*,@@ -108,4 +106,4 @@ web-routes-th >= 0.21, xss-sanitize == 0.3.* - -- Build-tools: trhsx+ -- Build-tools: hsx2hs