gistfile1.hs

-- | Request must contain a valid token including at least the specified scope.
data TokenScope (scope :: Symbol)
-- | All we can do for now is say that AUTHORIZATION is looked at.
--
-- TODO: Add Note to API sum type so tha we can add documentation notes for
-- this kind of thing.
instance (KnownSymbol scope, HasDocs sublayout)
            => HasDocs (TokenScope scope :> sublayout) where
    docsFor Proxy (endpoint, action) =
        docsFor sub (endpoint, action & headers %~ (|> "AUTHORIZATION"))
      where
        sub = Proxy :: Proxy sublayout

-- | Request must include a token and it should be checked against the supplied
-- scope.
--
-- This implementation looks for a /bearer/ token in the Authorization header
-- as described in RFC 6750. The header looks like:
--
-- @Authorization: Beader TOKENTEXT@
--
-- Checking that the supplied token is valid and has the required scope is
-- currently delegated to the handler, which is passed a 'ClientToken' value.
instance (KnownSymbol sym, HasServer sub) => HasServer (TokenScope sym :> sub)
  where
    type Server (TokenScope sym :> sub) = AnchorToken -> Server sub

    route Proxy subserver request respond = do
        key <- tryReadMVar oauth2Key
        let token = T.breakOn " " <$> requestToken request
        case (token, key) of
            (Just ("Bearer", t'), Just key') -> do
                let t = T.tail t'
                ident <- verifyToken key' t
                case ident of
                    Right i ->
                        case i ^. tokenType of
                            "access_token" | hasRequiredScope (i ^. tokenScope) ->
                                route (Proxy :: Proxy sub) (subserver i) request respond
                            _ -> respond $ S.failWith NotFound
                    Left _ -> respond $ failWith (400, "Bad Request") "Invalid or expired token"
            (_, Nothing) ->
                respond $ failWith (500, "Internal Server Error") "Server not ready"
            _ ->
                respond $ failWith (400, "Bad Request") "Missing or invalid token"
      where
        requestToken r = T.decodeUtf8 <$> lookup "Authorization" (requestHeaders r)
        scope = sort . T.splitOn " " . T.pack . symbolVal $ (Proxy :: Proxy sym)
        hasRequiredScope ts = scope == (scope `intersect` sort ts)

instance (KnownSymbol scope, HasClient sublayout) => HasClient (TokenScope scope :> sublayout) where

    type Client (TokenScope scope :> sublayout)
        = Text -> Client sublayout

    clientWithRoute Proxy req token =
        clientWithRoute (Proxy :: Proxy sublayout) $
            addHeader "Authorization" ("Bearer " <> T.unpack token) req