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