add df1-wai

cabal.project

@@ -9,3 +9,4 @@ packages:
   di-handle/
   di-monad/
   df1-html/
+  df1-wai/

df1-wai/CHANGELOG.md

@@ -0,0 +1,4 @@
+# Version 0.1
+
+* Initial version.
+

df1-wai/LICENSE.txt

@@ -0,0 +1,30 @@
+Copyright (c) 2024, Renzo Carbonara
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Renzo Carbonara nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

df1-wai/README.md

@@ -0,0 +1,3 @@
+# df1-wai
+
+`df1` formatting of `wai` requests and responses.

df1-wai/default.nix

@@ -0,0 +1,10 @@
+{ mkDerivation, base, df1, http-types, lib, text, wai }:
+mkDerivation {
+  pname = "df1-wai";
+  version = "0.1";
+  src = ./.;
+  libraryHaskellDepends = [ base df1 http-types text wai ];
+  homepage = "https://github.com/k0001/di";
+  description = "Df1 log formatting for WAI requests and responses";
+  license = lib.licenses.bsd3;
+}

df1-wai/df1-wai.cabal

@@ -0,0 +1,28 @@
+cabal-version: >=1.18
+name: df1-wai
+version: 0.1
+author: Renzo Carbonara
+maintainer: renλren.zone
+copyright: Renzo Carbonara 2024
+license: BSD3
+license-file: LICENSE.txt
+extra-source-files: README.md CHANGELOG.md
+category: Logging
+build-type: Simple
+synopsis: Df1 log formatting for WAI requests and responses
+description: Df1 log formatting for WAI requests and responses
+homepage: https://github.com/k0001/di
+bug-reports: https://github.com/k0001/di/issues
+
+library
+  hs-source-dirs: lib
+  default-language: GHC2021
+  exposed-modules: Df1.Wai
+  build-depends:
+    base >=4.9 && <5.0,
+    df1 >=0.3,
+    http-types,
+    text,
+    wai
+  ghc-options: -Wall -O2
+

df1-wai/lib/Df1/Wai.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Df1.Wai (request, response) where
+
+import Data.Functor
+import Data.Maybe
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
+import Df1
+import Network.HTTP.Types
+import Network.Wai
+
+request :: Request -> [(Key, Value)]
+request r =
+   mconcat
+      [ maybeToList $
+         requestHeaderHost r <&> \x ->
+            ("host", value (T.decodeUtf8 x))
+      ,
+         [ ("method", value (T.decodeUtf8 (requestMethod r)))
+         , ("path", value (T.intercalate "/" (pathInfo r)))
+         , ("query", value (T.decodeUtf8 (renderQuery False (queryString r))))
+         ,
+            ( "http"
+            , let HttpVersion mj mn = httpVersion r
+              in  value $ (shows mj . showChar '.' . shows mn) ""
+            )
+         ]
+      , maybeToList $
+         requestHeaderReferer r <&> \x ->
+            ("referer", value (T.decodeUtf8 x))
+      , maybeToList $
+         requestHeaderUserAgent r <&> \x ->
+            ("user-agent", value (T.decodeUtf8 x))
+      ,
+         [ ("secure", value (isSecure r))
+         ,
+            ( "body-length"
+            , case requestBodyLength r of
+               ChunkedBody -> "chunked"
+               KnownLength x -> value x
+            )
+         , ("peer", value (show (remoteHost r)))
+         ]
+      ]
+
+response :: Response -> [(Key, Value)]
+response r =
+   [ ("status", value (statusCode (responseStatus r)))
+   ]