From 025eb70c992914fbdf018c189d358ae250d2eeb1 Mon Sep 17 00:00:00 2001
From: Clint Adams <clint@softwarefreedom.org>
Date: Mon, 22 Oct 2012 15:19:04 -0400
Subject: This needs to be cleaned and sanitized before publication.

---
 Auth/Proxied.hs | 37 +++++++++++++++++++++++++++++++++++++
 1 file changed, 37 insertions(+)
 create mode 100644 Auth/Proxied.hs

(limited to 'Auth')

diff --git a/Auth/Proxied.hs b/Auth/Proxied.hs
new file mode 100644
index 0000000..684a3a1
--- /dev/null
+++ b/Auth/Proxied.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Auth.Proxied
+    ( authProxied
+    ) where
+
+import Yesod.Auth
+import Yesod.Handler (notFound)
+import Text.Hamlet (hamlet)
+import Yesod.Widget (toWidget)
+
+import Yesod.Handler (waiRequest)
+import Data.List (lookup)
+import Data.Maybe (fromMaybe)
+import Network.Wai (Request(requestHeaders))
+import Prelude (($), (.), Bool(..), fmap, either, const, Maybe(..), (/=), (=<<), return, show)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base64 as Base64
+import Data.CaseInsensitive (mk)
+import Data.Text.Encoding (decodeUtf8)
+
+
+authProxied :: YesodAuth m => AuthPlugin m
+authProxied =
+    AuthPlugin "proxied" dispatch login
+  where
+    dispatch _ [] = do
+        mfu <- fmap ((fmap (decodeUtf8 . B.takeWhile (58 /=)) . either (const Nothing) return . Base64.decode . B.drop 1 . B.dropWhile (32 /=) =<<) . lookup (mk "Authorization") . requestHeaders) waiRequest
+        setCreds True $ Creds "proxied" (fromMaybe "" mfu) []
+    dispatch _ _ = notFound
+    login authToMaster =
+        let url = authToMaster (PluginR "proxied" []) in
+        toWidget [hamlet|
+    Your new identifier is: #
+    <a href="@{url}">Zoinkz
+|]
-- 
cgit v1.2.3