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

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


lookupPagingParams :: Handler (Maybe Int64, Maybe Int64)
lookupPagingParams :: Handler (Maybe Int64, Maybe Int64)
lookupPagingParams =
  (,)
  (Maybe Int64 -> Maybe Int64 -> (Maybe Int64, Maybe Int64))
-> HandlerFor App (Maybe Int64)
-> HandlerFor App (Maybe Int64 -> (Maybe Int64, Maybe Int64))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> HandlerFor App (Maybe Int64)
forall a. (Show a, Read a) => Text -> Handler (Maybe a)
getUrlSessionParam Text
"count"
  HandlerFor App (Maybe Int64 -> (Maybe Int64, Maybe Int64))
-> HandlerFor App (Maybe Int64)
-> Handler (Maybe Int64, Maybe Int64)
forall a b.
HandlerFor App (a -> b) -> HandlerFor App a -> HandlerFor App b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> HandlerFor App (Maybe Int64)
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
  (Maybe Text -> Maybe a)
-> HandlerFor App (Maybe Text) -> Handler (Maybe a)
forall a b. (a -> b) -> HandlerFor App a -> HandlerFor App b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Text -> Maybe a
forall {a} {b}.
(Element a ~ Char, Read b, MonoFoldable a) =>
Maybe a -> Maybe b
parseMaybe (Text -> HandlerFor App (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
name)
  where
    parseMaybe :: Maybe a -> Maybe b
parseMaybe Maybe a
x = String -> Maybe b
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe b) -> (a -> String) -> a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> String
a -> [Element a]
forall mono. MonoFoldable mono => mono -> [Element mono]
unpack (a -> Maybe b) -> Maybe a -> Maybe b
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 <- (Maybe Text -> Maybe a)
-> HandlerFor App (Maybe Text) -> Handler (Maybe a)
forall a b. (a -> b) -> HandlerFor App a -> HandlerFor App b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Text -> Maybe a
parseMaybe (Text -> HandlerFor App (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
name)
  Maybe a
s <- (Maybe Text -> Maybe a)
-> HandlerFor App (Maybe Text) -> Handler (Maybe a)
forall a b. (a -> b) -> HandlerFor App a -> HandlerFor App b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Text -> Maybe a
parseMaybe (Text -> HandlerFor App (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
name)
  Maybe a
-> (Element (Maybe a) -> HandlerFor App ()) -> HandlerFor App ()
forall mono (f :: * -> *) b.
(MonoFoldable mono, Applicative f) =>
mono -> (Element mono -> f b) -> f ()
for_ Maybe a
p (Text -> Text -> HandlerFor App ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
name (Text -> HandlerFor App ())
-> (a -> Text) -> a -> HandlerFor App ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (String -> Text
[Element Text] -> Text
forall seq. IsSequence seq => [Element seq] -> seq
pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> String
forall a. Show a => a -> String
show))
  Maybe a -> Handler (Maybe a)
forall a. a -> HandlerFor App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a
p Maybe a -> Maybe a -> Maybe a
forall a. Maybe a -> Maybe a -> Maybe a
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 = String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe a) -> (Text -> String) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> String
Text -> [Element Text]
forall mono. MonoFoldable mono => mono -> [Element mono]
unpack (Text -> Maybe a) -> Maybe Text -> Maybe a
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
  (ByteString -> Maybe TagCloudMode
forall a. FromJSON a => ByteString -> Maybe a
A.decode (ByteString -> Maybe TagCloudMode)
-> (ByteString -> ByteString) -> ByteString -> Maybe TagCloudMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
forall lazy strict. LazySequence lazy strict => strict -> lazy
fromStrict (ByteString -> Maybe TagCloudMode)
-> Maybe ByteString -> Maybe TagCloudMode
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Maybe ByteString -> Maybe TagCloudMode)
-> m (Maybe ByteString) -> m (Maybe TagCloudMode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
Text -> m (Maybe ByteString)
lookupSessionBS Text
"tagCloudMode"

setTagCloudMode :: MonadHandler m => TagCloudMode -> m ()
setTagCloudMode :: forall (m :: * -> *). MonadHandler m => TagCloudMode -> m ()
setTagCloudMode = Text -> ByteString -> m ()
forall (m :: * -> *). MonadHandler m => Text -> ByteString -> m ()
setSessionBS Text
"tagCloudMode" (ByteString -> m ())
-> (TagCloudMode -> ByteString) -> TagCloudMode -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> ByteString
forall lazy strict. LazySequence lazy strict => lazy -> strict
toStrict (ByteString -> ByteString)
-> (TagCloudMode -> ByteString) -> TagCloudMode -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TagCloudMode -> ByteString
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 <- m (Maybe TagCloudMode)
forall (m :: * -> *). MonadHandler m => m (Maybe TagCloudMode)
lookupTagCloudMode
  let expanded :: Bool
expanded = Bool -> (TagCloudMode -> Bool) -> Maybe TagCloudMode -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False TagCloudMode -> Bool
isExpanded Maybe TagCloudMode
ms
  TagCloudMode -> m TagCloudMode
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TagCloudMode -> m TagCloudMode) -> TagCloudMode -> m TagCloudMode
forall a b. (a -> b) -> a -> b
$
    if Bool -> Bool
not Bool
isowner
      then TagCloudMode
TagCloudModeNone
      else if Bool -> Bool
not ([Text] -> Bool
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