1 {-# LANGUAGE OverloadedStrings #-}
    2 module Databrary.Controller.Angular
    3   ( JSOpt(..)
    4   , jsURL
    5   , angular
    6   -- * Used by servant
    7   , angularRequest
    8   ) where
    9 
   10 import Control.Arrow (second)
   11 import qualified Data.ByteString as BS
   12 import qualified Data.ByteString.Builder as BSB
   13 import Data.Default.Class (Default(..))
   14 import Network.HTTP.Types (hUserAgent, QueryLike(..))
   15 import qualified Network.Wai as Wai
   16 import qualified Text.Regex.Posix as Regex
   17 
   18 import Databrary.Has
   19 import Databrary.Action
   20 import Databrary.HTTP (encodePath')
   21 import Databrary.HTTP.Request
   22 import Databrary.View.Angular
   23 import Databrary.Web
   24 import Databrary.Web.Service (Web, getWebVersion)
   25 
   26 data JSOpt
   27   = JSDisabled
   28   | JSDefault
   29   | JSEnabled
   30   deriving (Eq, Ord)
   31 
   32 instance Default JSOpt where
   33   def = JSDefault
   34 
   35 instance Monoid JSOpt where
   36   mempty = JSDefault
   37   mappend JSDefault j = j
   38   mappend j _ = j
   39 
   40 instance QueryLike JSOpt where
   41   toQuery JSDisabled = [("js", Just "0")]
   42   toQuery JSDefault = []
   43   toQuery JSEnabled = [("js", Just "1")]
   44 
   45 jsEnable :: Bool -> JSOpt
   46 jsEnable False = JSDisabled
   47 jsEnable True = JSEnabled
   48 
   49 -- | Extract any \'js\' query param, passing its value back as the first part of
   50 -- the tuple. Also return a modified query string (builder) that sets the \'js\'
   51 -- param to the value specified as the first argument to this function.
   52 jsURL
   53     :: JSOpt -- ^ The value to use for the \'js\' param in the modified query string.
   54     -> Wai.Request
   55     -- ^ Incoming request where we get the original query string.
   56     --
   57     -- FIXME: Just take the string itself, rather than the whole request.
   58     -> (JSOpt, BSB.Builder)
   59     -- ^ The extracted value of the original \'js\' param, plus a new query
   60     -- string with the original param overridden.
   61 jsURL js req =
   62     second (encodePath' (Wai.pathInfo req) . (toQuery js ++))
   63         $ unjs
   64         $ Wai.queryString req
   65   where
   66     unjs [] = (JSDefault, [])
   67     unjs (("js", v) : q) = (jsEnable (boolParameterValue v), snd $ unjs q)
   68     unjs (x : q) = second (x :) $ unjs q
   69 
   70 -- | A regex of user agents we do not support.
   71 browserBlacklist :: Regex.Regex
   72 browserBlacklist = Regex.makeRegex
   73   ("^Mozilla/.* \\(.*\\<(MSIE [0-9]\\.[0-9]|AppleWebKit/.* Version/[0-5]\\..* Safari/)" :: String)
   74 
   75 -- | Enable angular when options and allowed browsers call for it.
   76 enableAngular :: JSOpt -> Wai.Request -> Bool
   77 enableAngular JSDisabled = const False
   78 enableAngular JSDefault = not . any (Regex.matchTest browserBlacklist) . lookupRequestHeader hUserAgent
   79 enableAngular JSEnabled = const True
   80 
   81 -- | Shall this be an Angular-enabled response? If so, return a modified query
   82 -- string (builder) that can be used to force an Angular-/disabled/ view.
   83 angularRequest :: Wai.Request -> Maybe BSB.Builder
   84 angularRequest req =
   85     if enableAngular jsopt req
   86     then Just nojs
   87     else Nothing
   88   where (jsopt, nojs) = jsURL JSDisabled req
   89 
   90 angularResult :: BS.ByteString -> BSB.Builder -> RequestContext -> IO ()
   91 angularResult version nojs reqCtx = do
   92   cssDeps <- (:[]) <$> makeWebFilePath "all.min.css"
   93   jsDeps <- (:[]) <$> makeWebFilePath "all.min.js"
   94   result $ okResponse [] (htmlAngular version cssDeps jsDeps nojs reqCtx)
   95 
   96 -- | Do or do not send the SPA. There is no try.
   97 --
   98 -- The decision is based on 'enableAngular', via 'angularRequest', which
   99 -- confusingly returns a query string with which the user could override the use
  100 -- of angular on a subsequent request.
  101 --
  102 -- If the SPA is sent, the 'result' machinery causes a short-circuit, ignoring
  103 -- any following actions in this Handler. If the SPA isn't sent, then nothing
  104 -- happens whatsoever right here, and the rest of the Handler may proceed.
  105 angular :: Handler ()
  106 angular = do
  107     (servWeb :: Web) <- peek
  108     let version = getWebVersion servWeb
  109     (b :: Maybe BSB.Builder) <- peeks angularRequest
  110     mapM_ (\nojsBldr -> focusIO (angularResult version nojsBldr)) b