{-# OPTIONS_GHC -fno-warn-orphans #-}

module Servant.Util.Combinators.Sorting.Server () where

import Universum

import Data.Char (isAlphaNum)
import qualified Data.List as L
import qualified Data.Set as S
import Servant.API (FromHttpApiData (..), (:>))
import Servant.Server (DefaultErrorFormatters, ErrorFormatters, HasServer (..), Tagged (..),
                       unTagged)
import Servant.Server.Internal.Context (HasContextEntry, type (.++))
import Text.Megaparsec ((<?>))
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P

import Servant.Util.Combinators.Sorting.Base
import Servant.Util.Common


-- | Ensure no name in entries repeat.
sortingCheckDuplicates :: [SortingItem] -> Either Text ()
sortingCheckDuplicates :: [SortingItem] -> Either Text ()
sortingCheckDuplicates [SortingItem]
items =
    let names :: [Text]
names = (SortingItem -> Text) -> [SortingItem] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map SortingItem -> Text
siName [SortingItem]
items
        duplicate :: Maybe Text
duplicate = [Text] -> Maybe Text
forall t. Container t => t -> Maybe (Element t)
safeHead ([Text] -> Maybe Text)
-> ([Text] -> [Text]) -> [Text] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> Maybe Text) -> [[Text]] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Text] -> Maybe Text
forall t. Container t => t -> Maybe (Element t)
safeHead ([Text] -> Maybe Text)
-> ([Text] -> [Text]) -> [Text] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1) ([[Text]] -> [Text]) -> ([Text] -> [[Text]]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [[Text]]
forall a. Eq a => [a] -> [[a]]
L.group ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort [Text]
names
    in Either Text ()
-> (Text -> Either Text ()) -> Maybe Text -> Either Text ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Either Text ()
forall (f :: * -> *). Applicative f => f ()
pass (\Text
n -> Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text
"Duplicated field " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall b a. (Show a, IsString b) => a -> b
show Text
n) Maybe Text
duplicate

-- | Consumes "sortBy" query parameter and fetches sorting parameters contained in it.
instance ( HasServer subApi ctx
         , HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters
         , ReifySortingItems base
         , ReifyParamsNames provided
         ) =>
         HasServer (SortingParams provided base :> subApi) ctx where
    type ServerT (SortingParams provided base :> subApi) m =
        SortingSpec provided base -> ServerT subApi m

    route :: Proxy (SortingParams provided base :> subApi)
-> Context ctx
-> Delayed env (Server (SortingParams provided base :> subApi))
-> Router env
route =
        (Proxy (SortParamsExpanded provided subApi)
 -> Context ctx
 -> Delayed env (Server (SortParamsExpanded provided subApi))
 -> Router env)
-> (Server (SortingParams provided base :> subApi)
    -> Server (SortParamsExpanded provided subApi))
-> Proxy (SortingParams provided base :> subApi)
-> Context ctx
-> Delayed env (Server (SortingParams provided base :> subApi))
-> Router env
forall api api' (ctx :: [*]) env.
(Proxy api
 -> Context ctx -> Delayed env (Server api) -> Router env)
-> (Server api' -> Server api)
-> Proxy api'
-> Context ctx
-> Delayed env (Server api')
-> Router env
inRouteServer @(SortParamsExpanded provided subApi) Proxy (SortParamsExpanded provided subApi)
-> Context ctx
-> Delayed env (Server (SortParamsExpanded provided subApi))
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route ((Server (SortingParams provided base :> subApi)
  -> Server (SortParamsExpanded provided subApi))
 -> Proxy (SortingParams provided base :> subApi)
 -> Context ctx
 -> Delayed env (Server (SortingParams provided base :> subApi))
 -> Router env)
-> (Server (SortingParams provided base :> subApi)
    -> Server (SortParamsExpanded provided subApi))
-> Proxy (SortingParams provided base :> subApi)
-> Context ctx
-> Delayed env (Server (SortingParams provided base :> subApi))
-> Router env
forall a b. (a -> b) -> a -> b
$
        \Server (SortingParams provided base :> subApi)
handler Maybe (Tagged provided [SortingItem])
rawSortItems -> Server (SortingParams provided base :> subApi)
SortingSpec provided base -> ServerT subApi Handler
handler ([SortingItem] -> SortingSpec provided base
forall (provided :: [TyNamedParam *])
       (base :: [TyNamedParam (SortingOrderType *)]).
ReifySortingItems base =>
[SortingItem] -> SortingSpec provided base
SortingSpec ([SortingItem] -> SortingSpec provided base)
-> [SortingItem] -> SortingSpec provided base
forall a b. (a -> b) -> a -> b
$ (Tagged provided [SortingItem] -> [SortingItem])
-> Maybe (Tagged provided [SortingItem]) -> Maybe [SortingItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tagged provided [SortingItem] -> [SortingItem]
forall k (s :: k) b. Tagged s b -> b
unTagged Maybe (Tagged provided [SortingItem])
rawSortItems Maybe [SortingItem] -> [SortingItem] -> [SortingItem]
forall a. Maybe a -> a -> a
?: [])

    hoistServerWithContext :: Proxy (SortingParams provided base :> subApi)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (SortingParams provided base :> subApi) m
-> ServerT (SortingParams provided base :> subApi) n
hoistServerWithContext Proxy (SortingParams provided base :> subApi)
_ Proxy ctx
pc forall x. m x -> n x
nt ServerT (SortingParams provided base :> subApi) m
s =
        Proxy subApi
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT subApi m
-> ServerT subApi n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy subApi
forall k (t :: k). Proxy t
Proxy @subApi) Proxy ctx
pc forall x. m x -> n x
nt (ServerT subApi m -> ServerT subApi n)
-> (SortingSpec provided base -> ServerT subApi m)
-> SortingSpec provided base
-> ServerT subApi n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (SortingParams provided base :> subApi) m
SortingSpec provided base -> ServerT subApi m
s

-- | Parse 'sort_by' query param.
-- Following the format described in "Sorting" section of https://www.moesif.com/blog/technical/api-design/REST-API-Design-Filtering-Sorting-and-Pagination/
instance ReifyParamsNames allowed =>
         FromHttpApiData (TaggedSortingItemsList allowed) where
    parseUrlPiece :: Text -> Either Text (TaggedSortingItemsList allowed)
parseUrlPiece =
        (ParseErrorBundle Text Void -> Text)
-> Either
     (ParseErrorBundle Text Void) (TaggedSortingItemsList allowed)
-> Either Text (TaggedSortingItemsList allowed)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text
forall a. ToText a => a -> Text
toText (String -> Text)
-> (ParseErrorBundle Text Void -> String)
-> ParseErrorBundle Text Void
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
P.errorBundlePretty) (Either
   (ParseErrorBundle Text Void) (TaggedSortingItemsList allowed)
 -> Either Text (TaggedSortingItemsList allowed))
-> (Text
    -> Either
         (ParseErrorBundle Text Void) (TaggedSortingItemsList allowed))
-> Text
-> Either Text (TaggedSortingItemsList allowed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([SortingItem] -> TaggedSortingItemsList allowed)
-> Either (ParseErrorBundle Text Void) [SortingItem]
-> Either
     (ParseErrorBundle Text Void) (TaggedSortingItemsList allowed)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [SortingItem] -> TaggedSortingItemsList allowed
forall k (s :: k) b. b -> Tagged s b
Tagged (Either (ParseErrorBundle Text Void) [SortingItem]
 -> Either
      (ParseErrorBundle Text Void) (TaggedSortingItemsList allowed))
-> (Text -> Either (ParseErrorBundle Text Void) [SortingItem])
-> Text
-> Either
     (ParseErrorBundle Text Void) (TaggedSortingItemsList allowed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        Parsec Void Text [SortingItem]
-> String
-> Text
-> Either (ParseErrorBundle Text Void) [SortingItem]
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
P.parse Parsec Void Text [SortingItem]
parser String
"sortBy"
      where
        parser :: Parsec Void Text [SortingItem]
parser = do
            [SortingItem]
items <- ParsecT Void Text Identity SortingItem
-> ParsecT Void Text Identity Char
-> Parsec Void Text [SortingItem]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
P.sepBy ParsecT Void Text Identity SortingItem
itemParser (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
',')
            (Text -> ParsecT Void Text Identity ())
-> (() -> ParsecT Void Text Identity ())
-> Either Text ()
-> ParsecT Void Text Identity ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> ParsecT Void Text Identity ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Void Text Identity ())
-> (Text -> String) -> Text -> ParsecT Void Text Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString) () -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text () -> ParsecT Void Text Identity ())
-> Either Text () -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ [SortingItem] -> Either Text ()
sortingCheckDuplicates [SortingItem]
items
            ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof
            [SortingItem] -> Parsec Void Text [SortingItem]
forall (m :: * -> *) a. Monad m => a -> m a
return [SortingItem]
items

        itemParser :: P.Parsec Void Text SortingItem
        itemParser :: ParsecT Void Text Identity SortingItem
itemParser = [ParsecT Void Text Identity SortingItem]
-> ParsecT Void Text Identity SortingItem
forall t (f :: * -> *) a.
(Container t, Alternative f, Element t ~ f a) =>
t -> f a
asum
            [ do
                SortingOrder
siOrder <- [ParsecT Void Text Identity SortingOrder]
-> ParsecT Void Text Identity SortingOrder
forall t (f :: * -> *) a.
(Container t, Alternative f, Element t ~ f a) =>
t -> f a
asum
                    [ SortingOrder
Ascendant SortingOrder
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity SortingOrder
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'+'
                    , SortingOrder
Descendant SortingOrder
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity SortingOrder
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'-'
                    ] ParsecT Void Text Identity SortingOrder
-> String -> ParsecT Void Text Identity SortingOrder
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"ordering sign (+/-)"
                Text
siName <- ParsecT Void Text Identity Text
paramNameParser
                SortingItem -> ParsecT Void Text Identity SortingItem
forall (m :: * -> *) a. Monad m => a -> m a
return SortingItem :: Text -> SortingOrder -> SortingItem
SortingItem{Text
SortingOrder
siOrder :: SortingOrder
siName :: Text
siOrder :: SortingOrder
siName :: Text
..}

            , do
                SortingOrder
siOrder <- [ParsecT Void Text Identity SortingOrder]
-> ParsecT Void Text Identity SortingOrder
forall t (f :: * -> *) a.
(Container t, Alternative f, Element t ~ f a) =>
t -> f a
asum
                    [ SortingOrder
Ascendant SortingOrder
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity SortingOrder
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
P.string' Tokens Text
"asc"
                    , SortingOrder
Descendant SortingOrder
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity SortingOrder
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
P.string' Tokens Text
"desc"
                    ] ParsecT Void Text Identity SortingOrder
-> String -> ParsecT Void Text Identity SortingOrder
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"ordering keyword (asc/desc)"
                Text
siName <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
'(' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Text
paramNameParser ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
Token Text
')'
                SortingItem -> ParsecT Void Text Identity SortingItem
forall (m :: * -> *) a. Monad m => a -> m a
return SortingItem :: Text -> SortingOrder -> SortingItem
SortingItem{Text
SortingOrder
siName :: Text
siOrder :: SortingOrder
siOrder :: SortingOrder
siName :: Text
..}
            ]

        allowedParams :: Set Text
allowedParams = ReifyParamsNames allowed => Set Text
forall k (params :: [TyNamedParam k]).
ReifyParamsNames params =>
Set Text
reifyParamsNamesSet @allowed

        paramNameParser :: ParsecT Void Text Identity Text
paramNameParser = do
            Text
name <- Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
P.takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"sorting item name") Char -> Bool
Token Text -> Bool
isAlphaNum ParsecT Void Text Identity Text
-> String -> ParsecT Void Text Identity Text
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"parameter name"
            Bool
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
name Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Text
allowedParams) (ParsecT Void Text Identity () -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity () -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$
                String -> ParsecT Void Text Identity ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Void Text Identity ())
-> String -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ String
"unknown parameter " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall b a. (Show a, IsString b) => a -> b
show Text
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
                       String
" (expected one of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Text] -> String
forall b a. (Show a, IsString b) => a -> b
show (Set Text -> [Element (Set Text)]
forall t. Container t => t -> [Element t]
toList Set Text
allowedParams) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
            Text -> ParsecT Void Text Identity Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
name