remove leftover rc3 things & some new stuff

this removes:
 - the bbb properties
 - all explicit mentions of rc3
 - the weird script domain hacks (done via a substitution now)
 - some (few) of the weirder code choices

it also adds some more type level witchery to deal with configs, which
for some reason seems to be the hardest problem of this entire program …

also the server now does inter-assembly dependency checking!

1 files changed, 45 insertions, 45 deletions

diff --git a/lib/Uris.hs b/lib/Uris.hs
index 596c272..40ea43e 100644
--- a/lib/Uris.hs
+++ b/lib/Uris.hs
@@ -1,9 +1,10 @@
-{-# LANGUAGE DataKinds        #-}
-{-# LANGUAGE DeriveAnyClass   #-}
-{-# LANGUAGE DeriveGeneric    #-}
-{-# LANGUAGE LambdaCase       #-}
-{-# LANGUAGE RecordWildCards  #-}
-{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TypeApplications  #-}
 
 -- | Functions to deal with uris and custom uri schemes
 module Uris where
@@ -16,7 +17,8 @@ import           Data.Aeson         (FromJSON (..), Options (..),
 import qualified Data.Map.Strict    as M
 import qualified Data.Text          as T
 import           GHC.TypeLits       (KnownSymbol, symbolVal)
-import           Network.URI        (URI (..), URIAuth (..), parseURI)
+import           Network.URI        (URI (..), URIAuth (..), parseURI,
+                                     uriToString)
 import qualified Network.URI.Encode as URI
 
 data Substitution =
@@ -24,7 +26,7 @@ data Substitution =
   | DomainSubstitution { substs :: Map Text Text, scope :: [String] }
   | Allowed  { scope :: [String], allowed :: [Text] }
   | Unrestricted { scope :: [String] }
-  deriving (Generic, Show)
+  deriving (Generic, Show, NFData)
 
 
 instance FromJSON Substitution where
@@ -33,30 +35,23 @@ instance FromJSON Substitution where
     , rejectUnknownFields = True
     }
 
-type SchemaSet = Map Text Substitution
+type SchemaSet = Map Text [Substitution]
 
 
-extractDomain :: Text -> Maybe Text
-extractDomain url =
-  case parseUri url of
-    Nothing           -> Nothing
-    Just (_,domain,_) -> Just domain
-
-
-
-
-parseUri :: Text -> Maybe (Text, Text, Text)
-parseUri uri =
-  case parseURI (toString uri) of
+-- | deconstruct a URI into a triple of [schema:]//[domain]/[tail...],
+-- and a normalised version of the same URI
+parseUri :: Text -> Maybe (Text, Text, Text, Text)
+parseUri raw =
+  case parseURI (toString raw) of
     Nothing -> Nothing
-    Just parsedUri -> case uriAuthority parsedUri of
+    Just uri@URI{..} -> case uriAuthority of
         Nothing -> Nothing
-        --                                             https:
-        Just uriAuth -> Just (T.replace (fromString ":") (fromString "") (fromString (uriScheme parsedUri )),
-        --             //anonymous@        www.haskell.org         :42
-          fromString(uriUserInfo uriAuth++uriRegName uriAuth ++ uriPort uriAuth),
-        --  /ghc          ?query                 #frag
-          fromString(uriPath parsedUri ++ uriQuery parsedUri ++ uriFragment parsedUri))
+        Just URIAuth {..} -> Just
+          ( fromString uriScheme
+          , fromString $ uriUserInfo <> uriRegName <> uriPort
+          , fromString $ uriPath <> uriQuery <> uriFragment
+          , fromString $ uriToString id uri ""
+          )
 
 
 data SubstError =
@@ -66,41 +61,46 @@ data SubstError =
   | IsBlocked
   | DomainIsBlocked [Text]
   | VarsDisallowed
+  | WrongScope Text [Text]
   -- ^ This link's schema exists, but cannot be used in this scope.
   -- The second field contains a list of schemas that may be used instead.
-  | WrongScope Text [Text]
   deriving (Eq, Ord) -- errors are ordered so we can show more specific ones
 
 
 applySubsts :: KnownSymbol s
   => Proxy s -> SchemaSet -> Text -> Either SubstError Text
 applySubsts s substs uri =  do
-  when (T.isInfixOf (toText "{{") uri || T.isInfixOf (toText "}}") uri)
+  when (T.isInfixOf "{{" uri || T.isInfixOf "}}" uri)
    $ Left VarsDisallowed
-  parts@(schema, _, _) <- note NotALink $ parseUri uri
+  parts@(schema, _, _, _) <- maybeToRight NotALink $ parseUri uri
 
-  let rule = M.lookup schema substs
+  let rules = filter (elem thisScope . scope) . concat $ M.lookup schema substs
 
-  case map (applySubst parts) rule of
-    Nothing  -> Left (SchemaDoesNotExist schema)
-    Just result -> result
+  case nonEmpty $ map (applySubst parts) rules of
+    Nothing     -> Left (SchemaDoesNotExist schema)
+    Just result -> minimum result
   where
-    note = maybeToRight
-    applySubst (schema, domain, rest) rule = do
+    thisScope = symbolVal s
+    applySubst (schema, domain, rest, uri) rule = do
+
+      -- is this scope applicable?
       unless (symbolVal s `elem` scope rule)
         $ Left (WrongScope schema
-         (map fst . filter (elem (symbolVal s) . scope . snd) $ toPairs substs))
+                 $ map fst -- make list of available uri schemes
+                 . filter (any (elem thisScope . scope) . snd)
+                 $ toPairs substs)
+
       case rule of
         DomainSubstitution table _  -> do
-          prefix <- note (DomainDoesNotExist (schema <> toText "://" <> domain))
-                       $ M.lookup domain table
+          prefix <- case M.lookup domain table of
+            Nothing -> Left (DomainDoesNotExist (schema <> "//" <> domain))
+            Just a  -> Right a
           pure (prefix <> rest)
         Prefixed {..}
           | domain `elem` blocked -> Left IsBlocked
-          | domain `elem` allowed || toText "streamproxy.rc3.world" `T.isSuffixOf` domain -> Right uri
+          | domain `elem` allowed -> Right uri
           | otherwise -> Right (prefix <> URI.encodeText uri)
-        Allowed _ domains -> if domain `elem` domains
-                    || toText "streamproxy.rc3.world" `T.isSuffixOf` domain
-          then Right uri
-          else Left (DomainIsBlocked domains)
+        Allowed _ allowlist
+          | domain `elem` allowlist -> Right uri
+          | otherwise -> Left (DomainIsBlocked allowlist)
         Unrestricted _ -> Right uri