module WASH.CGI.Cookie (T, check, create, createExpiring, init, initExpiring, get, set, current, delete) where
import Locale
import Maybe
import Prelude hiding (init)
import Random
import Time
import WASH.CGI.BaseCombinators
import WASH.CGI.CGIMonad
import WASH.HTML.HTMLMonad hiding (head, div, map, span)
import WASH.CGI.Types
import WASH.CGI.StateItem
check :: (Read a, Show a, Types a) => String -> CGI (Maybe (T a))
create :: (Read a, Show a, Types a) => String -> a -> CGI (T a)
createExpiring :: (Read a, Show a, Types a) => String -> Int -> a -> CGI (T a)
init :: (Read a, Show a, Types a) => String -> a -> CGI (T a)
initExpiring :: (Read a, Show a, Types a) => String -> Int -> a -> CGI (T a)
get :: (Read a, Show a, Types a) => T a -> CGI (Maybe a)
set :: (Read a, Show a, Types a) => T a -> a -> CGI (Maybe (T a))
current :: (Read a, Show a, Types a) => T a -> CGI (Maybe (T a))
delete :: (Types a) => T a -> CGI ()
data P a = P { nr :: Int, vl :: a }
deriving (Read, Show)
t :: String -> P a -> T a
t name (P i a) = T name i
check name =
once (unsafe_getHandle name)
unsafe_getHandle name =
CGI (\cgistate ->
let mresult = fmap (t name) $ cookieLookup cgistate typedName
myTyspec = ty (tvirtual (fromJust mresult))
typedName = makeTypedName name myTyspec
in
return (mresult, cgistate))
create name val =
once (unsafe_init False name val Nothing)
createExpiring name minutes val =
once $ do timestr <- unsafe_io $ getTimeString minutes
unsafe_init False name val (Just timestr)
initExpiring name minutes val =
once $ do timestr <- unsafe_io $ getTimeString minutes
unsafe_init True name val (Just timestr)
init name val =
once (unsafe_init True name val Nothing)
unsafe_init useExisting name val mexp =
CGI (\cgistate ->
case cookieLookup cgistate typedName of
Just pair | useExisting ->
return (t name pair, cgistate)
_ ->
do nonce <- randomIO
let p0val = P nonce val
cm' = (typedName, (Just (show p0val), mexp)) : cookieMap cgistate
cts' = typedName : cookiesToSend cgistate
return (t name p0val,
cgistate { cookieMap = cm'
, cookiesToSend = cts'
}))
where myTyspec = ty val
typedName = makeTypedName name myTyspec
get handle =
once (do eitherTP <- unsafe_get_current handle
return $ either (const Nothing) Just eitherTP)
current handle =
once (do eitherTP <- unsafe_get_current handle
return $ either Just (const Nothing) eitherTP)
unsafe_get_current :: (Types a, Read a, Show a) => T a -> CGI (Either (T a) a)
unsafe_get_current t@(T name i) =
CGI (\cgistate ->
case cookieLookup cgistate typedName of
(Just pair)
| nr pair == i ->
return (Right $ vl pair, cgistate)
| otherwise ->
return (Left $ T name (nr pair), cgistate)
_ ->
reportError "Cookie disappeared"
(do let cm = cookieMap cgistate
mms = lookup typedName cm
mmp = if True then fmap (fmap reads . fst) mms
else Just (Just [(P 0 $ tvirtual t, "")])
pre $ text $ (" " ++ typedName)
pre $ text $ show cm
pre $ text $ show mms
pre $ text $ show mmp)
cgistate)
where myTyspec = ty (tvirtual t)
typedName = makeTypedName name myTyspec
set handle val =
once (unsafe_set handle val)
unsafe_set (T name i) val =
CGI (\cgistate ->
case cookieLookup cgistate typedName of
(Just pair) | nr pair == i ->
do nonce <- randomIO
let pair' = if True then P nonce val else pair
cts = cookiesToSend cgistate
cts' = if typedName `elem` cts then cts else typedName : cts
cm' = (typedName, (Just (show pair'), Nothing)) :
[ entry | entry@(aName, _) <- cookieMap cgistate
, aName /= typedName ]
return (Just (t name pair'),
cgistate { cookieMap = cm'
, cookiesToSend = cts'
})
_ -> return (Nothing, cgistate))
where myTyspec = ty val
typedName = makeTypedName name myTyspec
delete t =
once (unsafe_delete t)
unsafe_delete t@(T name i) =
CGI (\cgistate ->
let cts = cookiesToSend cgistate
cts' = if typedName `elem` cts then cts else typedName : cts
in return ( ()
, cgistate { cookieMap = (typedName, (Nothing, Nothing))
: cookieMap cgistate
, cookiesToSend = cts'
}))
where myTyspec = ty (tvirtual t)
typedName = makeTypedName name myTyspec
cookieLookup :: (Show a, Read a) => CGIState -> String -> Maybe (P a)
cookieLookup cgistate typedName =
let cm = cookieMap cgistate
fn = lookup typedName cm
cn = fmap (fmap reads . fst) fn
checkType [] =
Nothing
checkType ((pair,_):_) =
Just pair
in cn >>= \mtp -> mtp >>= checkType
makeTypedName :: String -> TySpec -> String
makeTypedName s tys = s ++ '-' : tid tys ""
getTimeString :: Int -> IO String
getTimeString minutes =
do now <- getClockTime
let expireAt = addToClockTime TimeDiff {tdYear = 0,
tdMonth = 0,
tdDay = 0,
tdHour = 0,
tdMin = minutes,
tdSec = 0,
tdPicosec = 0} now
fmt = "%a, %d-%b-%Y %H:%M:%S GMT"
loc = defaultTimeLocale
return $ formatCalendarTime loc fmt (toUTCTime expireAt)