Routes.hs

{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
module Snap.AtlassianConnect.Routes
  ( connectRoutes
  , homeHandler
  ) where

import           Control.Applicative
import qualified Control.Arrow                           as ARO
import           Control.Monad                           (mzero)
import           Control.Monad.State.Class               (get)
import qualified Data.Aeson                              as A
import qualified Data.ByteString.Char8                   as BC
import qualified Data.CaseInsensitive                    as CI
import           Data.Connect.Descriptor                 as D
import           Data.List
import           Data.List.Split                         (splitOn)
import qualified Data.Map.Lazy                           as ML
import           Data.Maybe                              (catMaybes, fromMaybe)
import qualified Network.HTTP.Media                      as NM
import qualified Snap.AtlassianConnect.Data              as CD
import qualified Snap.AtlassianConnect.LifecycleResponse as CL
import qualified Snap.Core                               as SC
import qualified Snap.Helpers                            as SH
import qualified Snap.Snaplet                            as SS

data MediaType = ApplicationJson | TextHtml deriving (Eq)

newtype OrdMediaType = OMT NM.MediaType deriving (Eq, Show)

instance Ord OrdMediaType where
   compare a b = compare (show a) (show b)

instance Show (MediaType) where
  show ApplicationJson = "application/json"
  show TextHtml = "text/html"

-- | In old versions of Atlassian Connect, if you queried the application root and your Accept headers wanted an
-- "application/json" response then they would return your Atlassian Connect descriptor and if the Accept headers
-- requested "text/html" then they returned your applications home page. This is a convenience method to enable that
-- behaviour to continue. If you use this method in your routes then you can make your home page behave in the same way.
-- This is not required for an Atlassian Connect application so feel free to just return home page content on your home
-- page and ignore this method.
homeHandler :: SS.Handler b CD.Connect () -> SS.Handler b CD.Connect ()
homeHandler sendHomePage = SC.method SC.GET handleGet <|> SH.respondWithError SH.badRequest "You can only GET the homepage."
  where
    handleGet = do
        potentialAcceptHeader <- SC.getHeader bsAccept <$> SC.getRequest
        case potentialAcceptHeader of
            Just acceptHeader -> fromMaybe unknownHeader (NM.mapAcceptMedia mediaTypeMap acceptHeader)
            Nothing -> mzero

    mediaTypeMap =
      [ (jsonMT, atlassianConnectHandler)
      , (textHtmlMT, sendHomePage)
      ]

    unknownHeader = SH.respondWithError SH.notFound "No response to a request with the provided Accept header."

    jsonMT = "application" NM.// "json"
    textHtmlMT = "text" NM.// "html"

bsAccept :: CI.CI BC.ByteString
bsAccept = CI.mk "Accept"

connectRoutes :: [(BC.ByteString, SS.Handler b CD.Connect ())]
connectRoutes = fmap (ARO.first BC.pack) simpleConnectRoutes

-- Handler b v a
-- b: lens from the base state to the current snaplets state (is the base state)
-- v: is the state of the current "view" snaplet (or simply, current state)
-- a: Monad return type
-- The MonadSnaplet type class distills the essence of the operations used with this pattern.
-- Its functions define fundamental methods for navigating snaplet trees.

simpleConnectRoutes :: [(String, SS.Handler b CD.Connect ())]
simpleConnectRoutes =
  [ ("/atlassian-connect.json" , atlassianConnectHandler)
  ]

atlassianConnectHandler :: SS.Handler b CD.Connect ()
atlassianConnectHandler = do
  connectData <- get
  let dc = genDescriptorExtrasFromConnect connectData
  SH.writeJson $ convertPluginDescriptor dc (CD.connectPlugin connectData)

genDescriptorExtrasFromConnect :: CD.Connect -> CD.DynamicDescriptorConfig
genDescriptorExtrasFromConnect connectData = CD.DynamicDescriptorConfig
    { CD.dcBaseUrl = CD.connectBaseUrl connectData
    }

convertPluginDescriptor :: CD.DynamicDescriptorConfig -> D.Plugin -> D.Plugin
convertPluginDescriptor dc plugin = plugin
    { D.pluginBaseUrl = CD.dcBaseUrl dc
    }