From a671937868dd65c6a92ee58b9d47d296d502b0ea Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Mon, 9 Sep 2019 16:40:01 +0200
Subject: [PATCH] fix: fix tests

---
 package.yaml                |  1 +
 src/Audit.hs                | 21 +++++++++++++++++----
 src/Handler/Material.hs     |  2 +-
 src/Handler/Utils/Course.hs |  2 +-
 src/Handler/Utils/Sheet.hs  |  2 +-
 src/Net/IP/Instances.hs     |  9 +++++++++
 src/Net/IPv6/Instances.hs   | 16 ++++++++++++++++
 7 files changed, 46 insertions(+), 7 deletions(-)
 create mode 100644 src/Net/IPv6/Instances.hs

diff --git a/package.yaml b/package.yaml
index bfd7e66ed..95b2739d5 100644
--- a/package.yaml
+++ b/package.yaml
@@ -136,6 +136,7 @@ dependencies:
   - constraints
   - memory
   - pqueue
+  - deepseq
 
 other-extensions:
   - GeneralizedNewtypeDeriving
diff --git a/src/Audit.hs b/src/Audit.hs
index ac8270edf..06d3d8767 100644
--- a/src/Audit.hs
+++ b/src/Audit.hs
@@ -20,6 +20,9 @@ import qualified Network.Wai as Wai
 import qualified Network.Socket as Wai
 
 import qualified Net.IP as IP
+import qualified Net.IPv6 as IPv6
+
+import Control.Exception (ErrorCall(..), evaluate)
 
 {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
 
@@ -30,18 +33,19 @@ data AuditRemoteException
 instance Exception AuditRemoteException
 
 
-getRemote :: (MonadHandler m, MonadThrow m, HasAppSettings (HandlerSite m)) => m IP
-getRemote = do
+getRemote :: forall m. (MonadHandler m, MonadCatch m, HasAppSettings (HandlerSite m)) => m IP
+getRemote = handle testHandler $ do
   ipFromHeader <- getsYesod $ view _appIpFromHeader
   wai <- waiRequest
 
-  if
+  ip <- if
     | ipFromHeader
     , Just ip <- byHeader wai
       -> return ip
     | otherwise
       -> byRemoteHost wai
-  
+
+  liftIO $ evaluate $!! ip
   where
     byHeader wai = listToMaybe $ do
       (h, v) <- Wai.requestHeaders wai
@@ -58,6 +62,15 @@ getRemote = do
             in return $ IP.ipv6 w1 w2 w3 w4 w5 w6 w7 w8
       _other -> throwM ARUnsupportedSocketKind
 
+    testHandler :: ErrorCall -> m IP
+    -- ^ `Yesod.Core.Unsafe.runFakeHandler` does not set a `Wai.remoteHost`
+    --
+    -- We catch only the specific error call used by
+    -- `Yesod.Core.Unsafe.runFakeHandler` and replace it with `IPv6.any` as a
+    -- placeholder value for testing.
+    testHandler (ErrorCall "runFakeHandler-remoteHost") = return $ IP.fromIPv6 IPv6.any
+    testHandler err = throwM err
+
 
 data AuditException
   = AuditRemoteException AuditRemoteException
diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs
index 3c8a4d150..791475e71 100644
--- a/src/Handler/Material.hs
+++ b/src/Handler/Material.hs
@@ -356,7 +356,7 @@ postMDelR tid ssh csh mnm = do
     , drSuccessMessage = SomeMessage $ MsgMaterialDeleted mnm
     , drSuccess = SomeRoute $ CourseR tid ssh csh   MaterialListR
     , drAbort   = SomeRoute $ CourseR tid ssh csh $ MaterialR mnm MShowR
-    , drDelete  = \_ -> id  -- TODO: audit 
+    , drDelete  = const id  -- TODO: audit 
     }
 
 -- | Serve all material-files
diff --git a/src/Handler/Utils/Course.hs b/src/Handler/Utils/Course.hs
index 0b54617f7..7f7645100 100644
--- a/src/Handler/Utils/Course.hs
+++ b/src/Handler/Utils/Course.hs
@@ -24,5 +24,5 @@ courseDeleteRoute drRecords = DeleteRoute
   , drSuccessMessage = SomeMessage MsgCourseDeleted
   , drAbort = error "drAbort undefined"
   , drSuccess = error "drSuccess undefined"
-  , drDelete = \_ -> id  -- TODO: audit
+  , drDelete = const id  -- TODO: audit
   }
diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs
index c3f16c18d..b3161ac89 100644
--- a/src/Handler/Utils/Sheet.hs
+++ b/src/Handler/Utils/Sheet.hs
@@ -79,5 +79,5 @@ sheetDeleteRoute drRecords = DeleteRoute
   , drSuccessMessage = SomeMessage MsgSheetDeleted
   , drAbort = error "drAbort undefined"
   , drSuccess = error "drSuccess undefined"
-  , drDelete = \_ -> id  -- TODO: audit
+  , drDelete = const id  -- TODO: audit
   }
diff --git a/src/Net/IP/Instances.hs b/src/Net/IP/Instances.hs
index c7e1995f7..59a1b32b1 100644
--- a/src/Net/IP/Instances.hs
+++ b/src/Net/IP/Instances.hs
@@ -12,6 +12,13 @@ import Database.Persist.Sql
 
 import qualified Data.Text.Encoding as Text
 
+import Control.DeepSeq (NFData)
+
+import Net.IPv6.Instances ()
+
+
+deriving instance Generic IP
+
 
 instance PersistField IP where
   toPersistValue = PersistDbSpecific . encodeUtf8 . IP.encode
@@ -21,3 +28,5 @@ instance PersistField IP where
   fromPersistValue _ = Left "IP-address values must be converted from PersistDbSpecific, PersistText, or PersistByteString"
 instance PersistFieldSql IP where
   sqlType _ = SqlOther "inet"
+
+instance NFData IP
diff --git a/src/Net/IPv6/Instances.hs b/src/Net/IPv6/Instances.hs
new file mode 100644
index 000000000..348dbb969
--- /dev/null
+++ b/src/Net/IPv6/Instances.hs
@@ -0,0 +1,16 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Net.IPv6.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Net.IPv6 (IPv6)
+import qualified Net.IPv6 as IPv6
+
+import Control.DeepSeq (NFData)
+
+
+deriving instance Generic IPv6
+
+instance NFData IPv6