-- | Common handler functions.
module Handler.Common where

import Import

import Data.FileEmbed (embedFile)
import Text.Read
import Data.Aeson as A

-- These handlers embed files in the executable at compile time to avoid a
-- runtime dependency, and for efficiency.

getFaviconR :: Handler TypedContent
getFaviconR :: Handler TypedContent
getFaviconR = do forall (m :: * -> *). MonadHandler m => Int -> m ()
cacheSeconds forall a b. (a -> b) -> a -> b
$ Int
60 forall a. Num a => a -> a -> a
* Int
5
                 --cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> Content -> TypedContent
TypedContent ByteString
"image/x-icon"
                        forall a b. (a -> b) -> a -> b
$ forall a. ToContent a => a -> Content
toContent $(embedFile "config/favicon.ico")

getRobotsR :: Handler TypedContent
getRobotsR :: Handler TypedContent
getRobotsR = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> Content -> TypedContent
TypedContent ByteString
typePlain
                    forall a b. (a -> b) -> a -> b
$ forall a. ToContent a => a -> Content
toContent $(embedFile "config/robots.txt")


lookupPagingParams :: Handler (Maybe Int64, Maybe Int64)
lookupPagingParams :: Handler (Maybe Int64, Maybe Int64)
lookupPagingParams =
  (,)
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Show a, Read a) => Text -> Handler (Maybe a)
getUrlSessionParam Text
"count"
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Read a => Text -> Handler (Maybe a)
getUrlParam Text
"page"

getUrlParam :: (Read a) => Text -> Handler (Maybe a)
getUrlParam :: forall a. Read a => Text -> Handler (Maybe a)
getUrlParam Text
name = do
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {b}.
(Element a ~ Char, Read b, MonoFoldable a) =>
Maybe a -> Maybe b
parseMaybe (forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
name)
  where
    parseMaybe :: Maybe a -> Maybe b
parseMaybe Maybe a
x = forall a. Read a => String -> Maybe a
readMaybe forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall mono. MonoFoldable mono => mono -> [Element mono]
unpack forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe a
x

getUrlSessionParam :: forall a.
  (Show a, Read a)
  => Text
  -> Handler (Maybe a)
getUrlSessionParam :: forall a. (Show a, Read a) => Text -> Handler (Maybe a)
getUrlSessionParam Text
name = do
  Maybe a
p <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Text -> Maybe a
parseMaybe (forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
name)
  Maybe a
s <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Text -> Maybe a
parseMaybe (forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
name)
  forall mono (f :: * -> *) b.
(MonoFoldable mono, Applicative f) =>
mono -> (Element mono -> f b) -> f ()
for_ Maybe a
p (forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
name forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (forall seq. IsSequence seq => [Element seq] -> seq
pack forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Show a => a -> String
show))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a
p forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe a
s)
  where
    parseMaybe :: Maybe Text -> Maybe a
    parseMaybe :: Maybe Text -> Maybe a
parseMaybe Maybe Text
x = forall a. Read a => String -> Maybe a
readMaybe forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall mono. MonoFoldable mono => mono -> [Element mono]
unpack forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Text
x

lookupTagCloudMode :: MonadHandler m => m (Maybe TagCloudMode)
lookupTagCloudMode :: forall (m :: * -> *). MonadHandler m => m (Maybe TagCloudMode)
lookupTagCloudMode = do
  (forall a. FromJSON a => ByteString -> Maybe a
A.decode forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall lazy strict. LazySequence lazy strict => strict -> lazy
fromStrict forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadHandler m =>
Text -> m (Maybe ByteString)
lookupSessionBS Text
"tagCloudMode"

setTagCloudMode :: MonadHandler m => TagCloudMode -> m ()
setTagCloudMode :: forall (m :: * -> *). MonadHandler m => TagCloudMode -> m ()
setTagCloudMode = forall (m :: * -> *). MonadHandler m => Text -> ByteString -> m ()
setSessionBS Text
"tagCloudMode" forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall lazy strict. LazySequence lazy strict => lazy -> strict
toStrict forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. ToJSON a => a -> ByteString
A.encode

getTagCloudMode :: MonadHandler m => Bool -> [Tag] -> m TagCloudMode
getTagCloudMode :: forall (m :: * -> *).
MonadHandler m =>
Bool -> [Text] -> m TagCloudMode
getTagCloudMode Bool
isowner [Text]
tags = do
  Maybe TagCloudMode
ms <- forall (m :: * -> *). MonadHandler m => m (Maybe TagCloudMode)
lookupTagCloudMode
  let expanded :: Bool
expanded = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False TagCloudMode -> Bool
isExpanded Maybe TagCloudMode
ms
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    if Bool -> Bool
not Bool
isowner
      then TagCloudMode
TagCloudModeNone
      else if Bool -> Bool
not (forall mono. MonoFoldable mono => mono -> Bool
null [Text]
tags)
             then Bool -> [Text] -> TagCloudMode
TagCloudModeRelated Bool
expanded [Text]
tags
             else case Maybe TagCloudMode
ms of
                    Maybe TagCloudMode
Nothing -> Bool -> Int -> TagCloudMode
TagCloudModeTop Bool
expanded Int
200
                    Just (TagCloudModeRelated Bool
e [Text]
_) -> Bool -> Int -> TagCloudMode
TagCloudModeTop Bool
e Int
200
                    Just TagCloudMode
m -> TagCloudMode
m