git.iko.soy/obelisk
on decrease-android-validity help sign in
obelisk/lib/frontend/src/Obelisk/Frontend/Cookie.hs
102 lines 3.4 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DefaultSignatures #-}
4{-# LANGUAGE DeriveFunctor #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE RankNTypes #-}
10{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE UndecidableInstances #-}
13module Obelisk.Frontend.Cookie where
15import Control.Monad.Fix
16import Control.Monad.Primitive
17import Control.Monad.Ref
18import Control.Monad.IO.Class
19import Control.Monad.Trans.Class
20import Control.Monad.Trans.Reader
21import Data.Text.Encoding (encodeUtf8)
22import Reflex
23import Reflex.Host.Class
24import Reflex.Dom.Core
25import GHCJS.DOM.Document (getCookie, Document)
26import GHCJS.DOM.Types (MonadJSM)
27import Web.Cookie
29import Obelisk.Configs
30import Obelisk.Route.Frontend
32class Monad m => HasCookies m where
33 askCookies :: m Cookies
34 default askCookies :: (HasCookies m', m ~ t m', MonadTrans t) => m Cookies
35 askCookies = lift askCookies
37instance HasCookies m => HasCookies (BehaviorWriterT t w m)
38instance HasCookies m => HasCookies (DynamicWriterT t w m)
39instance HasCookies m => HasCookies (EventWriterT t w m)
40instance HasCookies m => HasCookies (PostBuildT t m)
41instance HasCookies m => HasCookies (QueryT t q m)
42instance HasCookies m => HasCookies (ReaderT r m)
43instance HasCookies m => HasCookies (RequesterT t request response m)
44instance HasCookies m => HasCookies (RouteToUrlT t m)
45instance HasCookies m => HasCookies (SetRouteT t r m)
46instance HasCookies m => HasCookies (StaticDomBuilderT t m)
47instance HasCookies m => HasCookies (TriggerEventT t m)
48instance HasCookies m => HasCookies (RoutedT t r m)
49instance HasCookies m => HasCookies (ConfigsT m)
50instance HasConfigs m => HasConfigs (CookiesT m)
52newtype CookiesT m a = CookiesT { unCookiesT :: ReaderT Cookies m a }
53 deriving
54 ( Functor
55 , Applicative
56 , DomBuilder t
57 , Monad
58 , MonadFix
59 , MonadHold t
60 , MonadIO
61#ifndef ghcjs_HOST_OS
62 , MonadJSM
63#endif
64 , MonadRef
65 , MonadReflexCreateTrigger t
66 , MonadSample t
67 , MonadTrans
68 , NotReady t
69 , PerformEvent t
70 , PostBuild t
71 , Prerender js t
72 , TriggerEvent t
73 , HasDocument
74 )
76instance Adjustable t m => Adjustable t (CookiesT m) where
77 runWithReplace a e = CookiesT $ runWithReplace (unCookiesT a) (unCookiesT <$> e)
78 traverseDMapWithKeyWithAdjust f m e = CookiesT $ traverseDMapWithKeyWithAdjust (\k v -> unCookiesT $ f k v) m e
79 traverseIntMapWithKeyWithAdjust f m e = CookiesT $ traverseIntMapWithKeyWithAdjust (\k v -> unCookiesT $ f k v) m e
80 traverseDMapWithKeyWithAdjustWithMove f m e = CookiesT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unCookiesT $ f k v) m e
82instance PrimMonad m => PrimMonad (CookiesT m) where
83 type PrimState (CookiesT m) = PrimState m
84 primitive = lift . primitive
86runCookiesT
87 :: Cookies
88 -> CookiesT m a
89 -> m a
90runCookiesT cs child = runReaderT (unCookiesT child) cs
92instance Monad m => HasCookies (CookiesT m) where
93 askCookies = CookiesT ask
95mapCookiesT
96 :: (forall x. m x -> n x)
97 -> CookiesT m a
98 -> CookiesT n a
99mapCookiesT f (CookiesT x) = CookiesT $ mapReaderT f x
101instance (MonadJSM m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => HasCookies (HydrationDomBuilderT s t m) where
102 askCookies = fmap (parseCookies . encodeUtf8) $ getCookie =<< askDocument