diff --git a/Clckwrks.hs b/Clckwrks.hs
--- a/Clckwrks.hs
+++ b/Clckwrks.hs
@@ -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 ()
diff --git a/Clckwrks/Acid.hs b/Clckwrks/Acid.hs
--- a/Clckwrks/Acid.hs
+++ b/Clckwrks/Acid.hs
@@ -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
diff --git a/Clckwrks/Admin/Console.hs b/Clckwrks/Admin/Console.hs
--- a/Clckwrks/Admin/Console.hs
+++ b/Clckwrks/Admin/Console.hs
@@ -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 =
diff --git a/Clckwrks/Admin/EditSettings.hs b/Clckwrks/Admin/EditSettings.hs
--- a/Clckwrks/Admin/EditSettings.hs
+++ b/Clckwrks/Admin/EditSettings.hs
@@ -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 -> [<% xml %>
])
divControlGroup = mapView (\xml -> [<% xml %>
])
diff --git a/Clckwrks/Admin/Template.hs b/Clckwrks/Admin/Template.hs
--- a/Clckwrks/Admin/Template.hs
+++ b/Clckwrks/Admin/Template.hs
@@ -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 ::
diff --git a/Clckwrks/BasicTemplate.hs b/Clckwrks/BasicTemplate.hs
--- a/Clckwrks/BasicTemplate.hs
+++ b/Clckwrks/BasicTemplate.hs
@@ -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 $
diff --git a/Clckwrks/Monad.hs b/Clckwrks/Monad.hs
--- a/Clckwrks/Monad.hs
+++ b/Clckwrks/Monad.hs
@@ -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 =
diff --git a/Clckwrks/NavBar/API.hs b/Clckwrks/NavBar/API.hs
--- a/Clckwrks/NavBar/API.hs
+++ b/Clckwrks/NavBar/API.hs
@@ -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
diff --git a/Clckwrks/NavBar/EditNavBar.hs b/Clckwrks/NavBar/EditNavBar.hs
--- a/Clckwrks/NavBar/EditNavBar.hs
+++ b/Clckwrks/NavBar/EditNavBar.hs
@@ -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 ()
diff --git a/Clckwrks/ProfileData/EditProfileData.hs b/Clckwrks/ProfileData/EditProfileData.hs
--- a/Clckwrks/ProfileData/EditProfileData.hs
+++ b/Clckwrks/ProfileData/EditProfileData.hs
@@ -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 -> [<% xml %>
])
divControlGroup = mapView (\xml -> [<% xml %>
])
divControls = mapView (\xml -> [<% xml %>
])
- 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)
diff --git a/Clckwrks/ProfileData/EditProfileDataFor.hs b/Clckwrks/ProfileData/EditProfileDataFor.hs
--- a/Clckwrks/ProfileData/EditProfileDataFor.hs
+++ b/Clckwrks/ProfileData/EditProfileDataFor.hs
@@ -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
diff --git a/Clckwrks/Route.hs b/Clckwrks/Route.hs
--- a/Clckwrks/Route.hs
+++ b/Clckwrks/Route.hs
@@ -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
diff --git a/Clckwrks/URL.hs b/Clckwrks/URL.hs
--- a/Clckwrks/URL.hs
+++ b/Clckwrks/URL.hs
@@ -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)
diff --git a/Clckwrks/Unauthorized.hs b/Clckwrks/Unauthorized.hs
--- a/Clckwrks/Unauthorized.hs
+++ b/Clckwrks/Unauthorized.hs
@@ -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
diff --git a/HSP/HTMLBuilder.hs b/HSP/HTMLBuilder.hs
deleted file mode 100644
--- a/HSP/HTMLBuilder.hs
+++ /dev/null
@@ -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\> instead of \