From 4381213446644ec98b1a0b5c00dd2e01b45615c3 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@rel4tion.org>
Date: Sun, 24 Apr 2016 18:48:07 +0000
Subject: [PATCH] Binary request body decoder

---
 src/Data/Binary/Local.hs |  1 -
 src/Vervis/BinaryBody.hs | 42 ++++++++++++++++++++++++++++++++++++++++
 vervis.cabal             |  1 +
 3 files changed, 43 insertions(+), 1 deletion(-)
 create mode 100644 src/Vervis/BinaryBody.hs

diff --git a/src/Data/Binary/Local.hs b/src/Data/Binary/Local.hs
index a903672..9f6f050 100644
--- a/src/Data/Binary/Local.hs
+++ b/src/Data/Binary/Local.hs
@@ -76,7 +76,6 @@ decodeIncremental
     -- value again from the same stream, pass the buffer to the next call of
     -- this function.
 decodeIncremental src readBytes buf decode = go buf $ runGetIncremental decode
-    --readBytes <- requestBody <$> waiRequest
     where
     go _ (Fail remains consumed err) = do
         let df = DecodeFail
diff --git a/src/Vervis/BinaryBody.hs b/src/Vervis/BinaryBody.hs
new file mode 100644
index 0000000..ef6c30d
--- /dev/null
+++ b/src/Vervis/BinaryBody.hs
@@ -0,0 +1,42 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- | Support for working with HTTP request bodies which contain binary
+-- serialization, using the @binary@ package.
+--
+-- TODO add ToContent, ToTypedContent etc. instances with Get and Put support
+-- TODO rename module to Yesod.<some>.<thing>.Local
+-- TODO maybe split into entirely separate small trivial package?
+module Vervis.BinaryBody
+    ( decodeRequestBody
+    )
+where
+
+import Prelude
+
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Logger (MonadLogger)
+import Data.Binary.Get (Get)
+import Network.Wai (requestBody)
+import Yesod.Core (MonadHandler)
+import Yesod.Core.Handler (waiRequest)
+
+import Data.Binary.Local
+
+decodeRequestBody
+    :: (MonadLogger m, MonadHandler m) => Get a -> m (Either DecodeFail a)
+decodeRequestBody decode = do
+    readBytes <- liftIO . requestBody <$> waiRequest
+    fmap snd <$> decodeIncremental "DecodeReq" readBytes Nothing decode
diff --git a/vervis.cabal b/vervis.cabal
index 01f8677..362657a 100644
--- a/vervis.cabal
+++ b/vervis.cabal
@@ -42,6 +42,7 @@ library
                        Network.SSH.Local
                        Text.FilePath.Local
                        Vervis.Application
+                       Vervis.BinaryBody
                        Vervis.Content
                        Vervis.Field.Key
                        Vervis.Field.Person