nuthatch/test/WebContractIntegration.hs

module Main (main) where

import qualified Data.ByteString as BS
import qualified Data.Text as T
import           Network.Wai (Request)
import           Network.Wai.Handler.Warp (testWithApplication)
import           Nuthatch.Api
import           Nuthatch.Types
import           Servant
import           Servant.Server.Experimental.Auth
  ( AuthHandler
  , mkAuthHandler
  )
import           Servant.Types.SourceT (source)
import           System.Process (callProcess)

main :: IO ()
main =
  testWithApplication (pure application) $ \port ->
    callProcess
      "node"
      [ "web/test/contract-integration.mjs"
      , "http://127.0.0.1:" <> show port
      ]

application :: Application
application =
  serveWithContext
    (Proxy :: Proxy ProductApi)
    (authentication :. EmptyContext)
    productServer

authentication :: AuthHandler Request SessionContext
authentication = mkAuthHandler $ \_ ->
  pure SessionContext
    { sessionUser = SessionUser
        { suIssuer = "issuer"
        , suSubject = "subject"
        , suUserId = UserId "user-1"
        , suDisplay = Just "User"
        }
    , sessionCsrf =
        Just (CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")
    }

productServer :: Server ProductApi
productServer =
       sessionHandler
  :<|> browseHandler
  :<|> downloadHandler
  :<|> uploadHandler
  :<|> deleteHandler
  :<|> deletePlanHandler
  :<|> deleteBatchHandler

sessionHandler :: SessionContext -> Handler SessionResponse
sessionHandler session =
  pure SessionResponse
    { sessionResponseUserId = suUserId (sessionUser session)
    , sessionResponseDisplay = suDisplay (sessionUser session)
    , sessionResponseCsrf =
        CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
    }

browseHandler
  :: SessionContext
  -> Maybe Root
  -> Maybe BrowsePrefix
  -> Maybe SearchQuery
  -> Maybe PaginationToken
  -> Handler BrowseResponse
browseHandler _ _ prefix query continuation =
  pure BrowseResponse
    { browseEntries =
        [ EntryResponse
            { entryResponseName = maybe "root" browsePrefixName prefix
            , entryResponseIsPrefix = False
            , entryResponseSize = Just 3
            , entryResponsePath = maybe "root" browsePrefixName prefix
            }
        ]
    , browseContinuation = continuation
    , browsePartial = maybe False (const True) query
    }
  where
    browsePrefixName (BrowsePrefix selected) =
      maybe "" unRelativePath selected

downloadHandler
  :: SessionContext
  -> Root
  -> RelativePath
  -> Maybe T.Text
  -> Handler DownloadSuccess
downloadHandler _ _ _ _ =
  pure $
    addHeader
      "attachment; filename=\"file.txt\"" $
      addHeader "nosniff" $
        addHeader "default-src 'none'" $
          addHeader 3 (source ["abc"])

uploadHandler
  :: SessionContext
  -> Root
  -> RelativePath
  -> OperationId
  -> DeclaredSize
  -> ContentSha256
  -> CsrfToken
  -> SourceIO BS.ByteString
  -> Handler UploadResponse
uploadHandler _ _ _ operation _ _ _ _ =
  pure UploadResponse
    { uploadResponseOperationId = operation
    , uploadResponseResult = MutationSucceeded
    , uploadResponseIdempotencyWindowSeconds = 3600
    }

deleteHandler
  :: SessionContext
  -> DeleteRequest
  -> Handler DeleteResponse
deleteHandler _ request =
  pure DeleteResponse
    { deleteResponseOperationId = deleteOperationId request
    , deleteResponseResult = MutationSucceeded
    , deleteResponseIdempotencyWindowSeconds = 3600
    }

deletePlanHandler
  :: SessionContext
  -> Root
  -> RelativePath
  -> Maybe PaginationToken
  -> Handler DeletePlanResponse
deletePlanHandler _ _ path continuation =
  pure DeletePlanResponse
    { deletePlanPaths = [path]
    , deletePlanContinuation = continuation
    }

deleteBatchHandler
  :: SessionContext
  -> DeleteBatchRequest
  -> Handler DeleteBatchResponse
deleteBatchHandler _ request =
  pure $ DeleteBatchResponse
    [ DeleteItemResponse
        { deleteItemPath = deleteBatchPath item
        , deleteItemOperationId = deleteBatchOperationId item
        , deleteItemResult = Just MutationSucceeded
        , deleteItemError = Nothing
        }
    | item <- deleteBatchItems request
    ]