rfc 0.0.0.21 → 0.0.0.22
raw patch · 4 files changed
+53/−34 lines, 4 files
Files
- rfc.cabal +1/−1
- src/RFC/Miso/String.hs +24/−6
- src/RFC/Servant/ApiDoc.hs +14/−20
- src/RFC/Wai.hs +14/−7
rfc.cabal view
@@ -1,5 +1,5 @@ name: rfc-version: 0.0.0.21+version: 0.0.0.22 synopsis: Robert Fischer's Common library description: An enhanced Prelude and various utilities for Aeson, Servant, PSQL, and Redis that Robert Fischer uses. homepage: https://github.com/RobertFischer/rfc#README.md
src/RFC/Miso/String.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-dodgy-exports #-} @@ -10,12 +11,29 @@ , module Miso.String ) where -import Data.Function (id, (.))-import Data.String (String)+import Data.Function (id, (.))+import Data.String (String) import Data.String.Conversions-import Miso.String (MisoString, ToMisoString (..))-import RFC.Data.UUID as UUID+import Miso.String (MisoString, ToMisoString (..))+import Miso.Subscription.History (URI (..))+import RFC.Data.UUID as UUID+import Text.Show ++instance {-# OVERLAPPING #-} ConvertibleStrings URI MisoString where+ convertString = toMisoString . show++instance {-# OVERLAPPING #-} ConvertibleStrings URI URI where+ convertString = id++instance {-# OVERLAPPABLE #-} (ConvertibleStrings String a) => ConvertibleStrings URI a where+ {-# SPECIALIZE instance ConvertibleStrings URI String #-}+ {-# SPECIALIZE instance ConvertibleStrings URI LazyText #-}+ {-# SPECIALIZE instance ConvertibleStrings URI StrictText #-}+ {-# SPECIALIZE instance ConvertibleStrings URI LazyByteString #-}+ {-# SPECIALIZE instance ConvertibleStrings URI StrictByteString #-}+ convertString = convertString . show+ instance {-# OVERLAPPING #-} ConvertibleStrings UUID.UUID MisoString where convertString = toMisoString . UUID.toString @@ -23,18 +41,18 @@ convertString = id instance {-# OVERLAPPABLE #-} (ToMisoString str) => ConvertibleStrings MisoString str where+ {-# SPECIALIZE instance ConvertibleStrings MisoString String #-} {-# SPECIALIZE instance ConvertibleStrings MisoString LazyText #-} {-# SPECIALIZE instance ConvertibleStrings MisoString StrictText #-} {-# SPECIALIZE instance ConvertibleStrings MisoString LazyByteString #-} {-# SPECIALIZE instance ConvertibleStrings MisoString StrictByteString #-}- {-# SPECIALIZE instance ConvertibleStrings MisoString String #-} convertString = fromMisoString instance {-# OVERLAPPABLE #-} (ToMisoString str) => ConvertibleStrings str MisoString where+ {-# SPECIALIZE instance ConvertibleStrings String MisoString #-} {-# SPECIALIZE instance ConvertibleStrings LazyText MisoString #-} {-# SPECIALIZE instance ConvertibleStrings StrictText MisoString #-} {-# SPECIALIZE instance ConvertibleStrings LazyByteString MisoString #-} {-# SPECIALIZE instance ConvertibleStrings StrictByteString MisoString #-}- {-# SPECIALIZE instance ConvertibleStrings String MisoString #-} convertString = toMisoString
src/RFC/Servant/ApiDoc.hs view
@@ -11,7 +11,7 @@ ( apiToHtml , apiToAscii , apiToSwagger- , apiApplication+ , apiMiddleware , swaggerSchemaOptions , ToSchemaRFC ) where@@ -52,11 +52,11 @@ apiToSwagger :: (HasSwagger a) => Proxy a -> Swagger apiToSwagger = toSwagger -apiApplication :: (HasDocs a, HasSwagger a) => Proxy a -> Swagger -> Application-apiApplication api addlSwagger request callback =- case reqMethod of- "GET" -> checkPath- _ -> failMethodNotAllowed+apiMiddleware :: (HasDocs a, HasSwagger a) => Proxy a -> Swagger -> Application -> Application+apiMiddleware api addlSwagger application request callback =+ case (reqMethod, reqPath) of+ ("GET", Just doIt) -> doIt+ _ -> application request callback where html = Blaze.renderHtml $ apiToHtml api ascii :: LazyByteString@@ -68,15 +68,15 @@ reqMethod = map Char.toUpper $ cs $ requestMethod request pathInfo :: String pathInfo = map Char.toLower $ cs $ rawPathInfo request- checkPath =+ reqPath = case pathInfo of- "swagger.json" -> serveSwagger- "/swagger.json" -> serveSwagger- "api.html" -> serveHtml- "/api.html" -> serveHtml- "api.txt" -> serveTxt- "/api.txt" -> serveTxt- _ -> failPathNotFound+ "swagger.json" -> Just serveSwagger+ "/swagger.json" -> Just serveSwagger+ "api.html" -> Just serveHtml+ "/api.html" -> Just serveHtml+ "api.txt" -> Just serveTxt+ "/api.txt" -> Just serveTxt+ _ -> Nothing response :: (ConvertibleStrings contentType StrictByteString, ConvertibleStrings body LazyByteString) => contentType -> body -> IO ResponseReceived@@ -85,12 +85,6 @@ serveHtml = response "text/html" html serveTxt = response "text/plain" ascii serveSwagger = response "application/json" swagger- failMethodNotAllowed :: IO ResponseReceived- failMethodNotAllowed = callback $- responseLBS status405 [(hContentType, cs "text/plain")] (cs $ "Unsupported HTTP method: " ++ reqMethod)- failPathNotFound :: IO ResponseReceived- failPathNotFound = callback $- responseLBS status404 [(hContentType, cs "text/plain")] (cs $ "Path not found: " ++ pathInfo) instance ToSample () where
src/RFC/Wai.hs view
@@ -5,28 +5,29 @@ , module Network.Wai ) where +import Control.Logger.Simple import Network.HTTP.Types.Header import Network.HTTP.Types.Method import Network.Wai import Network.Wai.Middleware.AcceptOverride-import Network.Wai.Middleware.Approot ( envFallback )+import Network.Wai.Middleware.Approot (envFallback) import Network.Wai.Middleware.Autohead import Network.Wai.Middleware.Cors import Network.Wai.Middleware.Gzip import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.MethodOverridePost-import Network.Wai.Middleware.RequestLogger ( logStdout, logStdoutDev )-import RFC.Env ( isDevelopment )+import Network.Wai.Middleware.RequestLogger (logStdout,+ logStdoutDev)+import RFC.Env (isDevelopment) import RFC.Prelude-import System.IO.Temp- ( createTempDirectory, getCanonicalTemporaryDirectory )+import System.IO.Temp (createTempDirectory, getCanonicalTemporaryDirectory) defaultMiddleware :: IO Middleware defaultMiddleware = do isDev <- isDevelopment approot <- envFallback- tmpDir <- getCanonicalTemporaryDirectory- gzipDir <- createTempDirectory tmpDir "wai-gzip-middleware"+ tmpDir <- getTmpDir+ gzipDir <- mkGzipDir tmpDir return $ methodOverridePost . acceptOverride .@@ -37,6 +38,12 @@ gzip (gzipConfig gzipDir) . (if isDev then logStdoutDev else logStdout) where+ handleError msg e = do+ logError . cs $ "Error while: " ++ msg+ logError . cs . show $ e+ throwIO e+ getTmpDir = catchAnyDeep getCanonicalTemporaryDirectory (handleError "getting temp dir")+ mkGzipDir tmpDir = catchAnyDeep (createTempDirectory tmpDir "wai-gzip-middleware") (handleError "making temp dir") corsConfig = simpleCorsResourcePolicy { corsRequireOrigin = False , corsVaryOrigin = False