{-# OPTIONS -fglasgow-exts -fno-monomorphism-restriction #-}
module Misc where
import HAppS.Server
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import Control.Monad.Trans
import Data.List
import qualified Data.Set as S
import Data.Digest.Pure.MD5
import Debug.Trace
import Text.PrettyPrint as PP
import Control.Applicative
import System.Directory
import System.FilePath
import Text.StringTemplate
import Data.Monoid
import Control.Monad.Reader
import Data.Char -- for rot13, which we shouldn't be using anyway
newtype HtmlString = HtmlString String
instance ToMessage HtmlString where
toContentType _ = B.pack "text/html"
toMessage (HtmlString s) = L.pack s
exactdir staticPath = spsIf (\rq -> rqURL rq == staticPath)
spsIf :: (Monad m) => (Request -> Bool) -> [ServerPartT m a] -> ServerPartT m a
spsIf p sps = withRequest $ \rq ->
if p rq
then unServerPartT (mconcat sps) rq
else mempty
traceTrue x = trace (show x ++ "\n\n") True
traceIt x = trace (show x ++ "\n\n") x
traceMsg msg x = trace ( "\n\n" ++ msg ++ (show x) ++ "\n\n") x
traceReadableMsg msg x = trace ( "\n\n" ++ msg ++ (show . show $ x) ++ "\n\n") x
pp[] = ( PP.render . vcat . map text . map show )
traceWith f v = trace (f v) v
instance (Monad m) => Monoid (ServerPartT m a)
where mempty = ServerPartT $ \rq -> noHandle
mappend a b = ServerPartT $ \rq -> (unServerPartT a rq) `mappend` (unServerPartT b rq)
instance (Monad m) => Monoid (WebT m a) where
mempty = noHandle
mappend a b = WebT $ do a' <- unWebT a
case a' of
NoHandle -> unWebT b
_ -> return a'
-- Chooses a template from an STGroup, or errors if not found.
-- Renders that template uses attrs, and gives the string.
-- if you don't clean and a template k/v pair is repeated, it appears twice.
-- Possibly this should be a fix inside StringTemplate. Tell sclv?
-- what is the expected StringTemplate behavior according to the original program?
--clean = nubBy (\(a1,b1) (a2,b2) -> a1 == a2) . sortBy (\(a1,b1) (a2,b2) -> a1 `compare` a2)
-- but then again, why should a key be repeated twice? maybe showing a repeat is a good thing
-- as it indicates buggy behavior
-- The ToSElem type is probably either String or [String]
--renderTemplateGroup :: (ToSElem a) => STGroup String -> [(String, a)] -> [Char] -> String
renderTemplateGroup :: STGroup String -> [(String, String)] -> [Char] -> String
renderTemplateGroup gr attrs tmpl =
maybe ( "template not found: " ++ tmpl )
( toString . setManyAttribSafer attrs )
( getStringTemplate tmpl gr )
----------------- reading data ----------------
readData :: RqData a -> Request -> Maybe a
readData rqDataReader rq = runReaderT rqDataReader $ (rqInputs rq,rqCookies rq)
readDataDef :: b -> (a -> b) -> RqData a -> Request -> b
readDataDef def f rqDataReader rq = maybe def f . readData rqDataReader $ rq
dataReaderToWeb :: RqData a -> Request -> WebT IO (Maybe a)
dataReaderToWeb rqDataReader rq = return . readData rqDataReader $ rq
dataReaderToWebDef :: b -> (a -> b) -> RqData a -> Request -> WebT IO b
dataReaderToWebDef def f rqDataReader rq = return . readDataDef def f rqDataReader $ rq
dataReaderToSp :: RqData a -> ServerPartT IO (Maybe a)
dataReaderToSp rqDataReader = withRequest $ \rq -> dataReaderToWeb rqDataReader rq
dataReaderToSpDef :: b -> (a->b) -> RqData a -> ServerPartT IO b
dataReaderToSpDef def f rqDataReader = withRequest $ \rq -> dataReaderToWebDef def f rqDataReader rq
alltrue ps x = foldr g True ps
where g p b = b && p x
nonetrue ps x = alltrue (map ( not . ) ps) x
pathPartsSp pps f = ServerPartT $ \rq ->
if rqPaths rq == pps
then f rq
else noHandle
-- Do something when the request has exactly one path segment left.
-- lastPathPartSp :: (Request -> String -> WebT IO Response) -> ServerPartT IO Response
lastPathPartSp0 f = ServerPartT $ \rq ->
case rqPaths rq of
[lastpart] -> f rq lastpart
_ -> noHandle
{-
ifFirstPathPartSp pathpart f = ServerPartT $ \rq ->
case rqPaths rq of
(x:xs) -> f rq pathpart
_ -> noHandle
-}
-- why can't I do this? ask #haskell sometime.
--instance Functor (S.Set a) where
-- fmap :: (a-> b ) (S.Set a) (S.Set b)
-- fmap f s = S.fromList . map f . S.toList $ s
-- for now just do rot13, but get this working for real. (md5? what do people use?)
scramblepass = show . md5 . L.pack -- map ( chr . (+13) . ord )
-- HStringTemplate modifications -- copy/paste/tweak from HStringTemplate.
-- same as directoryGroup, but throws an error for template names with punctuation
directoryGroupSafer :: (Stringable a) => FilePath -> IO (STGroup a)
directoryGroupSafer path = groupStringTemplates <$>
(fmap <$> zip . (map dropExtension)
<*> mapM (newSTMP <$$> (readFile . (path </>)))
=<< mapM checkTmplName
=<< return . filter (not . or . map (=='#') {-naughty emacs backup character-} )
. filter ( (".st" ==) . takeExtension )
=<< getDirectoryContents path)
where checkTmplName t = if ( badTmplVarName . takeBaseName ) t
then fail $ "safeDirectoryGroup, bad template name: " ++ t
else return t
(<$$>) :: (Functor f1, Functor f) => (a -> b) -> f (f1 a) -> f (f1 b)
(<$$>) x y = ((<$>) . (<$>)) x y
setManyAttribSafer attrs st =
let mbFoundbadattr = find badTmplVarName . map fst $ attrs
in maybe (setManyAttrib attrs st)
(\mbA -> newSTMP . ("setManyAttribSafer, bad template atr: "++) $ mbA)
mbFoundbadattr
badTmplVarName t = or . map (not . isAlpha) $ t
tFromTo = fromTo 10 20 [1..1000] == [10..20]
fromTo fr to xs = take (to-(fr-1)) . drop (fr-1) $ xs