QueryStringHash.hs

{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
module Snap.AtlassianConnect.QueryStringHash
    ( createQueryStringHash
    , generateQSH
    , module Network.HTTP.Types
    ) where

import           Control.Applicative
import           Control.Monad         (guard)
import qualified Crypto.Hash           as SHA
import qualified Data.ByteString.Char8 as B
import           Data.Function
import           Data.List
import           Data.List.Split
import           Data.Maybe
import           Data.Monoid
import           Data.Ord
import qualified Data.Text                  as T
import qualified Data.Text.Encoding         as TE
import           Network.HTTP.Types
import           Network.URI
import qualified Snap.Helpers               as SH
import qualified Snap.Core                  as SC
import qualified Snap.AtlassianConnect.Data as AC
import           Control.Monad.Trans.Class         (lift)
import           Control.Monad.Trans.Except

generateQSH :: (SC.MonadSnap m, AC.HasConnect m) => m (Either String T.Text)
generateQSH = runExceptT $ do
   connect <- lift $ AC.getConnect
   request <- lift $ SC.getRequest
   let connectBaseUrl = AC.connectBaseUrl connect
   incomingRequestUrl <- ExceptT $ getRequestUri connectBaseUrl
   let fullUrl = T.pack $ uriToString id incomingRequestUrl ""
   let rawMethod = SC.rqMethod $ request
   method <- except . SH.m2e (couldNotConvertMethod ++ (show rawMethod)) . convertMethod $ rawMethod
   except . SH.m2e qshGenerationFailed $ createQueryStringHash method connectBaseUrl fullUrl
   where
      couldNotConvertMethod = "Could not convert the incoming request method: "
      qshGenerationFailed = "Failed to generate a QSH for the current url"

getRequestUri :: SC.MonadSnap m => URI -> m (Either String URI)
getRequestUri connectBaseUrl = runExceptT $ do
   request <- lift $ SC.getRequest
   let rawRequestUri = B.unpack . SC.rqURI $ request
   temporaryUri <- except . SH.m2e (couldNotParseUrl ++ rawRequestUri) . parseURI $ "https://example.com" ++ rawRequestUri
   return $ temporaryUri
      { uriScheme = uriScheme connectBaseUrl
      , uriAuthority = uriAuthority connectBaseUrl
      }
   where
      couldNotParseUrl = "Could not parse the current URL that the App is processing: "

convertMethod :: SC.Method -> Maybe StdMethod
convertMethod SC.GET       = Just GET
convertMethod SC.HEAD      = Just HEAD
convertMethod SC.POST      = Just POST
convertMethod SC.PUT       = Just PUT
convertMethod SC.DELETE    = Just DELETE
convertMethod SC.TRACE     = Just TRACE
convertMethod SC.OPTIONS   = Just OPTIONS
convertMethod SC.CONNECT   = Just CONNECT
convertMethod SC.PATCH     = Just PATCH
convertMethod _            = Nothing
-- $setup
-- >>> import Data.Maybe
-- >>> import Data.Text

-- | Create a query string hash (required for the JWT claim set for an
-- Atlassian connect application) based on the HTTP method, the base URL
-- and the url to be used. This function will canonicalize the given URL
-- based on the rules outlined on <https://developer.atlassian.com/static/connect/docs/concepts/understanding-jwt.html#qsh>
--
-- >>> :{
--    let
--        baseUrl = fromMaybe nullURI $ parseURI "http://localhost:2990"
--        input   = "http://localhost:2990/path/to/service?a=1&A=2&b=3&B=4" :: Text
--    in createQueryStringHash GET baseUrl input
-- :}
-- Just "70282c7cf82834bd5a3d6dacda1b4ccd5cf5860a63a1fa2fb86b64d576e6a1d5"
createQueryStringHash :: StdMethod -> URI -> T.Text -> Maybe T.Text
createQueryStringHash method baseUrl fullUrl =
   (TE.decodeUtf8 . SHA.digestToHexByteString . hsh) <$> toCanonicalUrl method baseUrl fullUrl

hsh :: T.Text -> SHA.Digest SHA.SHA256
hsh = SHA.hash . TE.encodeUtf8

-- TODO we ask for the method just so that we can run show method on it...I think we should give it
-- here in a different way and not mandate StdMethod.
toCanonicalUrl :: StdMethod -> URI -> T.Text -> Maybe T.Text
toCanonicalUrl method baseUrl' rawFullUrl = do
   fullUrl <- parseURI (T.unpack rawFullUrl)
   guard (comparing uriScheme baseUrl' fullUrl == EQ)
   guard (comparing uriAuthority baseUrl' fullUrl == EQ)
   path' <- uriPath <$> stripBaseUrl baseUrl' fullUrl
   let sqs = sortedQueryString fullUrl
   return . T.pack $ intercalate "&" [show method, path', sqs]

sortedQueryString :: URI -> String
sortedQueryString = toCanonicalQueryString . parseQueryText . B.pack . uriQuery

stripBaseUrl :: URI -> URI -> Maybe URI
stripBaseUrl baseUrl' fullUrl = do
    strippedPath <- stripPrefix (uriPath baseUrl') (uriPath fullUrl)
    return fullUrl
        { uriScheme = ""
        , uriAuthority = Nothing
        , uriPath = strippedPath
        }

{-
 - See step 5 of Creating a Query Hash:
 - https://developer.atlassian.com/static/connect/docs/concepts/understanding-jwt.html
* Sort the query parameters primarily by their percent-encoded names and secondarily by their percent-encoded values
* Sorting is by codepoint: sort(["a", "A", "b", "B"]) => ["A", "B", "a", "b"]
* For each parameter append its percent-encoded name, the '=' character and then its percent-encoded value.
* In the case of repeated parameters append the ',' character and subsequent percent-encoded values.
* Ignore the jwt parameter, if present.
* Some particular values to be aware of:
    "+" is encoded as "%20",
    "*" as "%2A" and
    "~" as "~".
    (These values used for consistency with OAuth1.)
 This method needs to be functionally equivalent to: com.atlassian.jwt.core.HttpRequestCanonicalizer#canonicalizeQueryParameters from atlassian-jwt
-}
toCanonicalQueryString :: QueryText -> String
toCanonicalQueryString = T.unpack . render . joinQueryParams . groupAndSortQueryParams . ignoreJWTParam

type QueryParam = (T.Text, Maybe T.Text)

ignoreJWTParam :: [(T.Text, a)] -> [(T.Text, a)]
ignoreJWTParam = filter ((/= "jwt") . fst)

sortParamKeys :: Ord a => [(a, b)] -> [(a, b)]
sortParamKeys = sortBy (comparing fst)

sortParamValues :: Ord b => [(a, b)] -> [(a, b)]
sortParamValues = sortBy (comparing snd)

groupAndSortQueryParams :: [QueryParam] -> [[QueryParam]]
groupAndSortQueryParams = fmap sortParamValues . groupBy ((==) `on` fst) . sortParamKeys

joinQueryParams :: [[QueryParam]] -> [(T.Text, T.Text)]
joinQueryParams = catMaybes . fmap joinQueryParam

joinQueryParam :: [QueryParam] -> Maybe (T.Text, T.Text)
joinQueryParam [] = Nothing
joinQueryParam xs@(x : _) = return (encode . fst $ x, T.intercalate sep . fmap encode . catMaybes . fmap snd $ xs)
   where
      sep = T.singleton ','

queryParamToString :: (T.Text, T.Text) -> T.Text
queryParamToString (key, value) = key <> T.singleton '=' <> value

render :: [(T.Text, T.Text)] -> T.Text
render = T.intercalate "&" . fmap queryParamToString

encode :: T.Text -> T.Text
encode = TE.decodeUtf8 . urlEncode True . TE.encodeUtf8