Api.hs

-- | Core API description
module Mig.Core.Api (
  Api (..),
  Path (..),
  ApiNormal (..),
  toNormalApi,
  fromNormalApi,
  PathItem (..),
  getPath,
  CaptureMap,
  flatApi,
  fromFlatApi,
  MethodMap,
  OutputMediaMap (..),
  InputMediaMap (..),
  MediaMap (..),
) where

import Data.ByteString (ByteString)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.String
import Data.Text (Text)
import Data.Text qualified as Text
import Mig.Core.Class.Route qualified as Route
import Mig.Core.Types (RouteInfo (..), RouteOutput (..), getInputType)
import Network.HTTP.Media (mapAcceptMedia, mapContentMedia)
import Network.HTTP.Media.MediaType (MediaType)
import Network.HTTP.Types.Method
import System.FilePath
import Web.HttpApiData

-- | HTTP API container
data Api a
  = -- | alternative between two API's
    Append (Api a) (Api a)
  | -- | an empty API that does nothing
    Empty
  | -- | path prefix for an API
    WithPath Path (Api a)
  | -- | handle route
    HandleRoute a
  deriving (Functor, Foldable, Traversable, Show, Eq)

instance Monoid (Api a) where
  mempty = Empty

instance Semigroup (Api a) where
  (<>) = Append

-- | Filters routes in the API with predicate
filterApi :: (a -> Bool) -> Api a -> Api a
filterApi check = \case
  HandleRoute a -> if check a then HandleRoute a else Empty
  Append a b ->
    case rec a of
      Empty -> rec b
      otherA ->
        case rec b of
          Empty -> otherA
          otherB -> Append otherA otherB
  Empty -> Empty
  WithPath path a -> case rec a of
    Empty -> Empty
    other -> WithPath path other
  where
    rec = filterApi check

-- | converts API to efficient representation to fetch the route handlers by path
toNormalApi :: forall m. Api (Route.Route m) -> ApiNormal (Api (Route.Route m))
toNormalApi api = ApiNormal $ fmap (fmap toInputMediaMap . toOutputMediaMap) (toMethodMap api)
  where
    filterEmpty :: Map key (Api val) -> Map key (Api val)
    filterEmpty = Map.filter $ \case
      Empty -> False
      _ -> True

    toMethodMap :: Api (Route.Route m) -> MethodMap (Api (Route.Route m))
    toMethodMap a =
      filterEmpty $
        Map.fromList $
          fmap
            ( \m ->
                (m, filterApi (\route -> route.info.method == Just m) a)
            )
            methods
      where
        methods = foldMap (\route -> maybe [] pure route.info.method) a

    toInputMediaMap :: Api (Route.Route m) -> InputMediaMap (Api (Route.Route m))
    toInputMediaMap = InputMediaMap . toMediaMapBy getInputType

    toOutputMediaMap :: Api (Route.Route m) -> OutputMediaMap (Api (Route.Route m))
    toOutputMediaMap = OutputMediaMap . toMediaMapBy (\routeInfo -> Just routeInfo.output.media)

    toMediaMapBy :: (RouteInfo -> Maybe MediaType) -> Api (Route.Route m) -> MediaMap (Api (Route.Route m))
    toMediaMapBy getMedia a =
      MediaMap (filterAnyCases $ toMediaApi <$> medias) a
      where
        medias = Set.toList $ foldMap (\route -> maybe Set.empty Set.singleton (getMedia route.info)) a

        toMediaApi media = (media, filterApi (\route -> getMedia route.info == Just media) a)

        -- filter out any cases as they are covered by second argument of MediaMap value
        filterAnyCases = filter (("*/*" /=) . fst)

-- | Read sub-api by HTTP method, accept-type and content-type
fromNormalApi :: Method -> ByteString -> ByteString -> ApiNormal a -> Maybe a
fromNormalApi method outputAccept inputContentType (ApiNormal methodMap) = do
  OutputMediaMap outputMediaMap <- Map.lookup method methodMap
  InputMediaMap inputMediaMap <- lookupMediaMapBy mapAcceptMedia outputMediaMap outputAccept
  lookupMediaMapBy mapContentMedia inputMediaMap inputContentType

-- | Efficient representation of API to fetch routes
newtype ApiNormal a = ApiNormal (MethodMap (OutputMediaMap (InputMediaMap a)))
  deriving (Show, Eq, Functor)

-- | Mthod map
type MethodMap a = Map Method a

-- | filter by Content-Type header
newtype InputMediaMap a = InputMediaMap (MediaMap a)
  deriving (Show, Eq, Functor)

-- | filter by Accept header
newtype OutputMediaMap a = OutputMediaMap (MediaMap a)
  deriving (Show, Eq, Functor)

-- | Map by media type
data MediaMap a = MediaMap
  { mapValues :: [(MediaType, a)]
  , matchAll :: a
  }
  deriving (Show, Eq, Functor)

-- | Lookup value by media type key
lookupMediaMapBy :: ([(MediaType, a)] -> ByteString -> Maybe a) -> MediaMap a -> ByteString -> Maybe a
lookupMediaMapBy getter (MediaMap m matchAll) media
  | media == "*/*" = Just matchAll
  | otherwise = getter m media

{-| Path is a chain of elements which can be static types or capture.
There is @IsString@ instance which allows us to create paths from strings. Examples:

> "api/v1/foo" ==> Path [StaticPath "api", StaticPath "v1", StaticPath "foo"]
> "api/v1/*" ==> Path [StaticPath "api", StaticPath "v1", CapturePath "*"]
-}
newtype Path = Path {unPath :: [PathItem]}
  deriving newtype (Show, Eq, Ord, Semigroup, Monoid)

instance ToHttpApiData Path where
  toUrlPiece (Path ps) = Text.intercalate "/" $ fmap toUrlPiece ps

instance ToHttpApiData PathItem where
  toUrlPiece = \case
    StaticPath txt -> txt
    CapturePath txt -> "{" <> txt <> "}"

instance IsString Path where
  fromString =
    Path . fmap (replaceCapture . Text.pack) . filter (not . any isPathSeparator) . splitDirectories
    where
      replaceCapture :: Text -> PathItem
      replaceCapture path
        | Text.head path == '$' = CapturePath (Text.tail path)
        | path == "*" = CapturePath path
        | otherwise = StaticPath path

-- | Path can be a static item or capture with a name
data PathItem
  = StaticPath Text
  | CapturePath Text
  deriving (Show, Eq, Ord)

{-| Map of capture values extracted from path.
Keys are capture names.
-}
type CaptureMap = Map Text Text

-- | Find an api item by path. Also it accumulates capture map along the way.
getPath :: [Text] -> Api a -> Maybe (a, CaptureMap)
getPath mainPath = go mempty (filter (not . Text.null) mainPath)
  where
    go :: CaptureMap -> [Text] -> Api a -> Maybe (a, CaptureMap)
    go !captureMap path api =
      case path of
        [] -> case api of
          HandleRoute a -> Just (a, captureMap)
          Append a b -> maybe (go captureMap path b) Just (go captureMap path a)
          _ -> Nothing
        p : rest -> case api of
          WithPath template restApi -> goPath captureMap p rest template restApi
          Append a b -> maybe (go captureMap path b) Just (go captureMap path a)
          _ -> Nothing

    goPath !captureMap !pathHead !pathTail (Path !template) restApi =
      case template of
        [] -> go captureMap (pathHead : pathTail) restApi
        StaticPath apiHead : templateRest ->
          if pathHead == apiHead
            then goPathNext captureMap pathTail templateRest restApi
            else Nothing
        CapturePath name : templateRest ->
          let nextCaptureMap = Map.insert name pathHead captureMap
           in goPathNext nextCaptureMap pathTail templateRest restApi

    goPathNext !captureMap !pathTail !templateRest restApi =
      case templateRest of
        [] -> go captureMap pathTail restApi
        _ -> case pathTail of
          nextPathHead : nextPathTail -> goPath captureMap nextPathHead nextPathTail (Path templateRest) restApi
          [] -> Nothing

-- | Flattens API. Creates a flat list of paths and route handlers.
flatApi :: Api a -> [(Path, a)]
flatApi = go mempty
  where
    go prefix = \case
      Empty -> mempty
      Append a b -> go prefix a <> go prefix b
      WithPath path a -> go (prefix <> path) a
      HandleRoute a -> [(prefix, a)]

-- | Constructs API from flat list of pairs of paths and route handlers.
fromFlatApi :: [(Path, a)] -> Api a
fromFlatApi = foldMap (\(path, route) -> WithPath path (HandleRoute route))