From 8dc54a9fe68288d5dd366856143363ab0321116c Mon Sep 17 00:00:00 2001
From: Alfredo Di Napoli <alfredo.dinapoli@gmail.com>
Date: Mon, 5 Aug 2013 09:08:34 +0200
Subject: [PATCH 1/2] rest auth

---
 src/Snap/Extras/RestUtils.hs | 53 ++++++++++++++++++++++++++++++++++++
 1 file changed, 53 insertions(+)
 create mode 100644 src/Snap/Extras/RestUtils.hs

diff --git a/src/Snap/Extras/RestUtils.hs b/src/Snap/Extras/RestUtils.hs
new file mode 100644
index 0000000..35d2011
--- /dev/null
+++ b/src/Snap/Extras/RestUtils.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+
+module Snap.Extras.RestUtils
+    ( StatusCode
+    , AuthenticationRejection(..)
+    , AuthPolicy(..)
+    , withRestAuth) where
+
+-------------------------------------------------------------------------------
+import Snap.Core
+import Snap.Extras.CoreUtils (finishEarly)
+-------------------------------------------------------------------------------
+
+
+type StatusCode = Int
+
+
+data AuthenticationRejection = AuthenticationRejection
+    { rejectionCode :: StatusCode
+    , rejectionMessage :: ByteString } deriving (Show)
+
+
+--------------------------------------------------------------------------------
+-- | Specify the logic the authenticator will run in order to decide whether the
+-- route should be evaluated or rejected. It makes extremely simple writing
+-- authenticator like the following:
+--
+-- tokenAuthenticator :: AuthPolicy b v
+-- tokenAuthenticator = AuthPolicy $ hdlr -> do
+--   req <- getRequest
+--   let token = getHeader "Authorization" req
+--   return (maybe rejection lookupFn token)
+--   where
+--     rejection = Left (AuthenticationRejection 500 "Invalid token.")
+--     lookupFn t = if t == "SuperSecretToken" then Right () else rejection
+newtype AuthPolicy b v = AuthPolicy
+    { runPolicy :: Handler b v () ->
+                   Handler b v (Either AuthenticationRejection ()) }
+
+
+-------------------------------------------------------------------------------
+-- | Restful Authenticator, inspired to [Spray](http://spray.io/). The idea
+-- is to have an handler combinator which, given an authentication policy, is
+-- able to determine if the HTTP request should be "allowed" to continue or
+-- should be rejected with a particular error. This is particularly useful
+-- when developing restful services, which typically requires some sort of
+-- "low level authentication", for example an OAuth token to be passed in the
+-- HTTP header.
+withRestAuth :: AuthPolicy b v -> Handler b v () -> Handler b v ()
+withRestAuth policy hdlr = runPolicy policy hdlr >>= \res -> either
+    (\rej -> finishEarly (rejectionCode rej) (rejectionMessage rej))
+    (const hdlr) res

From 86abeff7d31167effcd1b11f374f291146cb76cb Mon Sep 17 00:00:00 2001
From: Alfredo Di Napoli <alfredo.dinapoli@gmail.com>
Date: Mon, 5 Aug 2013 09:23:07 +0200
Subject: [PATCH 2/2] First release of rest authenticator

---
 snap-extras.cabal            |  1 +
 src/Snap/Extras.hs           |  2 ++
 src/Snap/Extras/RestUtils.hs | 18 +++++++++---------
 3 files changed, 12 insertions(+), 9 deletions(-)

diff --git a/snap-extras.cabal b/snap-extras.cabal
index 7aed3e8..f5e2b13 100644
--- a/snap-extras.cabal
+++ b/snap-extras.cabal
@@ -32,6 +32,7 @@ Library
     Snap.Extras.FormUtils
     Snap.Extras.Tabs
     Snap.Extras.NavTrails
+    Snap.Extras.RestUtils
   other-modules:
     Snap.Extras.SpliceUtils.Common
     Paths_snap_extras
diff --git a/src/Snap/Extras.hs b/src/Snap/Extras.hs
index 482c56d..cba3905 100644
--- a/src/Snap/Extras.hs
+++ b/src/Snap/Extras.hs
@@ -7,6 +7,7 @@ module Snap.Extras
     , module Snap.Extras.FlashNotice
     , module Snap.Extras.FormUtils
     , module Snap.Extras.Tabs
+    , module Snap.Extras.RestUtils
     , initExtras
     ) where
 
@@ -26,6 +27,7 @@ import qualified Snap.Extras.SpliceUtils.Compiled as C
 import qualified Snap.Extras.SpliceUtils.Interpreted as I
 import           Snap.Extras.Tabs
 import           Snap.Extras.TextUtils
+import           Snap.Extras.RestUtils
 -------------------------------------------------------------------------------
 import Paths_snap_extras
 -------------------------------------------------------------------------------
diff --git a/src/Snap/Extras/RestUtils.hs b/src/Snap/Extras/RestUtils.hs
index 35d2011..515bd00 100644
--- a/src/Snap/Extras/RestUtils.hs
+++ b/src/Snap/Extras/RestUtils.hs
@@ -2,23 +2,23 @@
 
 
 module Snap.Extras.RestUtils
-    ( StatusCode
-    , AuthenticationRejection(..)
+    ( AuthenticationRejection(..)
     , AuthPolicy(..)
     , withRestAuth) where
 
 -------------------------------------------------------------------------------
-import Snap.Core
+import Snap.Snaplet
 import Snap.Extras.CoreUtils (finishEarly)
+import Data.ByteString (ByteString)
 -------------------------------------------------------------------------------
 
 
-type StatusCode = Int
-
-
 data AuthenticationRejection = AuthenticationRejection
-    { rejectionCode :: StatusCode
-    , rejectionMessage :: ByteString } deriving (Show)
+    { rejectionCode :: Int
+      -- ^ The HTTP status code of the failure
+    , rejectionMessage :: ByteString
+      -- ^ The rejection message
+    } deriving (Show)
 
 
 --------------------------------------------------------------------------------
@@ -43,7 +43,7 @@ newtype AuthPolicy b v = AuthPolicy
 -- | Restful Authenticator, inspired to [Spray](http://spray.io/). The idea
 -- is to have an handler combinator which, given an authentication policy, is
 -- able to determine if the HTTP request should be "allowed" to continue or
--- should be rejected with a particular error. This is particularly useful
+-- should be rejected with a particular error. This is useful
 -- when developing restful services, which typically requires some sort of
 -- "low level authentication", for example an OAuth token to be passed in the
 -- HTTP header.