Use HTTPS for avatar URL if approot in settings is https://

src/Vervis/Avatar.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -28,9 +28,8 @@ import Network.Wai (isSecure)
 import Yesod.Core (MonadHandler)
 import Yesod.Core.Handler (waiRequest)
 
-getAvatarUrl :: MonadHandler m => Text -> m (Maybe Text)
+getAvatarUrl :: MonadHandler m => Bool -> Text -> m (Maybe Text)
-getAvatarUrl email = do
+getAvatarUrl secure email = do
-    secure <- isSecure <$> waiRequest
     let opts = def
             { optSecure      = secure
             , optTryGravatar = False

src/Vervis/Foundation.hs

@@ -27,8 +27,9 @@ import Text.Hamlet          (hamletFile)
 import Yesod.Auth.Account
 import Yesod.Auth.Account.Message (AccountMsg (MsgUsernameExists))
 import Yesod.Auth.Message   (AuthMessage (IdentifierNotFound))
-import Yesod.Default.Util   (addStaticContentExternal)
 import Yesod.Core.Types     (Logger)
+import Yesod.Default.Util   (addStaticContentExternal)
+
 import Yesod.Mail.Send
 
 import qualified Yesod.Core.Unsafe as Unsafe

src/Vervis/Handler/Person.hs

@@ -31,6 +31,7 @@ import Text.Blaze.Html (toHtml)
 import Yesod.Auth.Account (newAccountR)
 
 import Vervis.Model.Ident
+import Vervis.Secure
 import Vervis.Widget (avatarW)
 
 -- | Get list of users
@@ -108,4 +109,5 @@ getPersonR ident = do
         Entity sid _s <- getBy404 $ UniqueSharer ident
         Entity _pid p <- getBy404 $ UniquePersonIdent sid
         return p
+    secure <- getSecure
     defaultLayout $(widgetFile "person")

src/Vervis/Secure.hs

@@ -0,0 +1,61 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2018 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/>.
+ -}
+
+-- | Sometimes we need to give the user a URL with a different domain than the
+-- main web application, but with the same protocol scheme: If we're running in
+-- HTTPS, then provide an HTTPS URL. And if we're running plain HTTP, provide
+-- an HTTP URL (not because HTTPS is bad, but because we may be serving that
+-- URL too and simply not providing SSL for it).
+--
+-- In order to construct that URL, we need to figure out whether the request
+-- we're serving is secured with HTTPS.
+--
+-- Since the web app may be running behind a reverse proxy, checking the
+-- request itself isn't enough - we need to know whether a reverse proxy may be
+-- serving our web app via HTTPS.
+--
+-- One way to detect that is @Forwarded@ headers in the request, but it seems
+-- they can be faked, i.e. just inserted manually by an HTTP client. So our
+-- approach here is to rely on the configured approot: If you use a reverse
+-- proxy, specify the approot in your web app settings file, otherwise only the
+-- request itself will be consulted.
+module Vervis.Secure
+    ( getSecure
+    )
+where
+
+import Prelude
+
+import Control.Monad ((<=<))
+import Data.Text (Text)
+import Network.Wai (isSecure)
+import Yesod.Core.Handler (getsYesod, waiRequest)
+
+import qualified Data.Text as T (take)
+
+import Vervis.Foundation
+import Vervis.Settings
+
+getSecure :: Handler Bool
+getSecure = do
+    let detectScheme t =
+            case T.take 5 t of
+                "https" -> Just True
+                "http:" -> Just False
+                _       -> Nothing
+    msec <- getsYesod $ detectScheme <=< appRoot . appSettings
+    case msec of
+        Nothing  -> isSecure <$> waiRequest
+        Just sec -> return sec

src/Vervis/Widget.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -53,9 +53,9 @@ revisionW =
         changes = $darcsTotalPatches :: Int
     in  $(widgetFile "widget/revision")
 
-avatarW :: Text -> WidgetT site IO ()
+avatarW :: Bool -> Text -> WidgetT site IO ()
-avatarW email = do
+avatarW secure email = do
-    murl <- getAvatarUrl email
+    murl <- getAvatarUrl secure email
     [whamlet|
         <div>
           $maybe url <- murl

templates/person.hamlet

@@ -1,6 +1,6 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -12,7 +12,7 @@ $# 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/>.
 
-^{avatarW $ personEmail person}
+^{avatarW secure $ personEmail person}
 
 <ul>
   <li>

vervis.cabal

@@ -92,8 +92,8 @@ library
                        Text.FilePath.Local
                        Text.Jasmine.Local
                        Web.PathPieces.Local
-                       Yesod.Paginate.Local
                        Yesod.Mail.Send
+                       Yesod.Paginate.Local
 
                        Vervis.Application
                        Vervis.Avatar
@@ -160,6 +160,7 @@ library
                        Vervis.Readme
                        Vervis.Render
                        Vervis.Role
+                       Vervis.Secure
                        Vervis.Settings
                        Vervis.Settings.StaticFiles
                        Vervis.SourceTree