packages feed

alto (empty) → 0

raw patch · 10 files changed

+597/−0 lines, 10 filesdep +MonadRandomdep +aesondep +altosetup-changed

Dependencies added: MonadRandom, aeson, alto, base, base64-bytestring, bytestring, containers, cryptohash-sha256, directory, exceptions, filepath, lens, list-tries, mtl, random, random-string, scrypt, servant-server, text, warp

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for alto++## 0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2018, davean++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of davean nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,10 @@+module Main where++import Alto.Web+import Alto.Menu+import Network.Wai.Handler.Warp++main :: IO ()+main = do+  conf <- AltoConfig <$> loadMenus <*> pure (ClientState mempty)+  run 8081 (altoApp conf)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ alto.cabal view
@@ -0,0 +1,61 @@+name:                alto+version:             0+synopsis:            Impliment a menu experience fit for web users.+description:+  A system for building cloud scale menu systems.++  For an example, see <https://xkcd.com/1975/ Right Click>.+homepage:            https://oss.xkcd.com/+license:             BSD3+license-file:        LICENSE+author:              davean+maintainer:          davean@xkcd.com+copyright:           davean 2018+category:            Web+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10++source-repository head+  type: git+  location: https://code.xkrd.net/xkcd/alto.git++library+  hs-source-dirs:      src+  default-language:    Haskell2010+  exposed-modules:+        Alto.Menu+      , Alto.Compile+      , Alto.Compile.Navigations+      , Alto.Example+      , Alto.Web+  build-depends:+        base >=4.10 && <4.12+      , mtl == 2.2.*+      , text == 1.2.*+      , containers == 0.5.*+      , bytestring == 0.10.*+      , lens == 4.16.*+      , cryptohash-sha256 == 0.11.*+      , scrypt == 0.5.*+      , base64-bytestring == 1.0.*+      , aeson == 1.3.*+      , servant-server == 0.13.*+      , filepath == 1.4.*+      , directory == 1.3.*+      , random-string == 0.1.*+      , list-tries == 0.6.*+      , MonadRandom == 0.5.*+      , random == 1.1.*+      , exceptions == 0.10.*++executable alto+  -- other-modules:+  -- other-extensions:+  -- hs-source-dirs:      src+  default-language:    Haskell2010+  main-is:             Main.hs+  build-depends:+        base >=4.10 && <4.12+      , alto+      , warp == 3.2.*
+ src/Alto/Compile.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE OverloadedStrings+  , ScopedTypeVariables+  , TupleSections+  , FlexibleContexts+ #-}+module Alto.Compile where++import           Alto.Menu+import           Control.Lens+import qualified Control.Monad.Catch as E+import           Control.Monad.Writer+import           Control.Monad.State+import qualified Crypto.Hash.SHA256 as SHA256+import           Crypto.Scrypt (ScryptParams)+import qualified Crypto.Scrypt as Scrypt+import qualified Data.ByteString.Base64.URL as B64+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Map as Map+import           Data.Maybe (fromJust)+import qualified Data.Set as Set+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import           System.RandomString++saltDerivingParams :: ScryptParams+saltDerivingParams = Scrypt.defaultParams++type MenuM a = StateT CompState IO a+type EntryM a = WriterT [MenuEntry] (StateT CompState IO) a++-- | Loads a subgraph if it exists, otherwise compiles it.+subGraph :: Text -> MenuM Menu -> MenuM Menu+subGraph sgName desc =+  E.catch (lift $ refSubGraph sgName) $ \(_::E.SomeException) -> do+    ms <- lift $ compileRoot sgName desc+    lift $ saveSubGraph sgName ms+    return . fromJust $ ms^.menuMap.at (ms^.topMenu.mid)++-- | Compiles a MenuSystem given a name we produce a salt from.+--   Any menu systems sharing tags must agree on the project name.+compileRoot :: Text -> MenuM Menu -> IO MenuSystem+compileRoot name desc = do+  let compSalt = B64.encode . Scrypt.getEncryptedPass . Scrypt.encryptPass+                 saltDerivingParams (Scrypt.Salt $ TE.encodeUtf8 "Jektulv!OCod3gob6Glaj@") .+                 Scrypt.Pass . TE.encodeUtf8 $ name+  (rm, (CSt _ mnmp _)) <- desc `runStateT` (CSt compSalt mempty mempty)+  return $ MenuSystem mnmp rm++idBytes :: Int+idBytes = 128 `div` 8++-- | Generate a (hopefully) unique ID based off the name, pseudo-salted from the root name.+--   The root derived pseudo salt is expensively generated to make guessing attacks+--   fairly unreasonable. Truly though this is just to keep the honest honest.+genTagID :: MonadState CompState m => Text -> m Tag+genTagID nm = do+  ss <- use salt+  -- If our parts encode the same, we are the same.+  return . T.init . TE.decodeUtf8 . B64.encode . BS.take idBytes .+    SHA256.hashlazy .+    BSL.fromChunks $ [TE.encodeUtf8 nm, ss]++genMenuID :: MenuM MenuID+genMenuID = lift $ randomString (StringOpts Base58 idBytes)++-- | Import a menu system for use in this menu system.+--   Returns the root of said menu system.+importMenuSystem :: MenuSystem -> MenuM Menu+importMenuSystem ms = do+  menus <>= (ms ^. menuMap)+  return (ms ^. topMenu)++runEntryM :: EntryM () -> MenuM [MenuEntry]+runEntryM = execWriterT++updateEntries :: Menu -> EntryM () -> MenuM ()+updateEntries m entry =+  void $ updateEntries' m entry++updateEntries' :: Menu -> EntryM () -> MenuM Menu+updateEntries' m entry = do+  ents <- runEntryM entry+  let+    m' = m & entries <>~ ents+  updateMenu m'+  return m'++menu' :: TagChange -> EntryM () -> MenuM Menu+menu' exitTC ents = do+  es <- runEntryM ents+  cid <- genMenuID+  let mn = Menu cid exitTC es+  -- Make sure this ID isn't already in use.+  omns <- menus <<%= (Map.insert cid mn)+  when (cid `Map.member` omns) $+    error ("The menu "<>(show es)<>" was already in used!")+  return $ mn++menu :: EntryM () -> MenuM Menu+menu = menu' mempty++updateMenu :: Menu -> MenuM ()+updateMenu m =+  menus #%= (Map.insert (m ^. mid) m)++uniqueTag :: MonadState CompState m => Text -> m Tag+uniqueTag t = do+  tid <- genTagID t+  existed <- use $ tags.contains tid+  when existed $ error "Tag already existed!"+  return tid++-- | Add an entry to the menu+ent :: MenuEntry -> EntryM ()+ent = tell . pure++mnAction :: Menu -> EntryType+mnAction m = SubMenu mempty (m^.mid) Nothing++andLogic :: TagLogic -> TagLogic -> TagLogic+andLogic nl Always = nl+andLogic nl (TLAnd ol) = TLAnd $ nl:ol+andLogic nl ol = TLAnd [nl, ol]++-- | Require a tag to be set for a menu entry to be displayed.+infixl 5 &++(&+) :: MenuEntry -> Tag -> MenuEntry+(&+) e t = e & display %~ andLogic (TagSet t)++-- | Require a tag to be unset for a menu entry to be displayed.+infixl 5 &-+(&-) :: MenuEntry -> Tag -> MenuEntry+(&-) e t = e & display %~ andLogic (TagUnset t)++-- | Requires a specific tag logic to be true.+infixl 5 &=+(&=) :: MenuEntry -> TagLogic -> MenuEntry+(&=) e tl = e & display %~ andLogic tl++-- Make a MenuEntry link to a submenu+-- (|-$) :: MenuEntry -> MenuM Menu -> MenuM MenuEntry++infixl 5 |->+(|->) :: MenuEntry -> Menu -> MenuEntry+(|->) e m = e & reaction .~ SubMenu (e^.reaction.onAction) (m ^. mid) Nothing++infixl 5 |-=+(|-=) :: MenuEntry -> Action -> MenuEntry+(|-=) e a = e & reaction .~ Action (e^.reaction.onAction) (Just a)++infixl 5 |-==+(|-==) :: MenuEntry -> EntryType -> MenuEntry+(|-==) e a = e & reaction .~ (a&onAction.~(e^.reaction.onAction))++infixl 5 |-//+(|-//) :: MenuEntry -> Text -> MenuEntry+(|-//) e u = e |-= (Nav u)++infixl 5 |-#+(|-#) :: MenuEntry -> Text -> EmbedSize -> MenuEntry+(|-#) e u es = e |-= (Embed u es)++-- | Make a MenuEntry set a tag.+infixl 5 |-++(|-+) :: MenuEntry -> Tag -> MenuEntry+(|-+) e t = e & reaction.onAction.setTags <>~ (Map.singleton t "")++-- | Make a MenuEntry sset a number of tags.+infixl 5 |-+*+(|-+*) :: MenuEntry -> [Tag] -> MenuEntry+(|-+*) e t = e & reaction.onAction.setTags <>~ (Map.fromList . map (,"") $ t)++-- | Make a MenuEntry set a tag.+infixl 5 |-+=+(|-+=) :: MenuEntry -> Tag -> Text -> MenuEntry+(|-+=) e t v = e & reaction.onAction.setTags <>~ (Map.singleton t v)++infixl 5 |-<>+(|-<>) :: MenuEntry -> TagChange -> MenuEntry+(|-<>) e tc = e & reaction.onAction <>~ tc++-- | Make a MenuEntry unset a tag.+infixl 5 |--+(|--) :: MenuEntry -> Tag -> MenuEntry+(|--) e t = e & reaction.onAction.unsetTags <>~ (Set.singleton t)++-- | Make a MenuEntry unset a number of tags.+infixl 5 |--*+(|--*) :: MenuEntry -> [Tag] -> MenuEntry+(|--*) e t = e & reaction.onAction.unsetTags <>~ (Set.fromList t)++-- | Like |-> but generates where it links off the value of a tag.+infixl 5 |=>+(|=>) :: MenuEntry -> Text -> Tag -> MenuEntry+(|=>) e mpre tg = e & reaction .~ SubMenu (e^.reaction.onAction) mpre (Just tg)
+ src/Alto/Compile/Navigations.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}+module Alto.Compile.Navigations where++import           Alto.Menu+import           Alto.Compile+import           Control.Lens+import           Control.Monad+import           Control.Monad.Trans+import           Data.ListTrie.Patricia.Map (TrieMap)+import qualified Data.ListTrie.Patricia.Map as LTP+import           Data.Map (Map)+import qualified Data.Text as T++-- | Makes a Patricia Trie into a set of actions.+--   Doesn't handle all Tries.+trieMenu :: [(String, EntryType)] -> MenuM Menu+trieMenu =+    go . LTP.fromList+  where+    go :: TrieMap Map Char EntryType -> MenuM Menu+    go = menu . breakPre+    breakPre :: TrieMap Map Char EntryType -> EntryM ()+    breakPre t = do+      iforM_ (LTP.children1 t) $ \fc st -> do+        case LTP.splitPrefix . LTP.addPrefix [fc] $ st of+          (pfx, Nothing, st') -> do+              sbmn <- lift $ go st'+              ent . MEntry Nothing (T.pack pfx) Always Always $ mnAction sbmn+          (pfx, Just a, st') -> do+              ent . MEntry Nothing (T.pack pfx) Always Always $ a+              unless (LTP.null st') $ do+                breakPre . LTP.addPrefix pfx $ st'+
+ src/Alto/Example.hs view
@@ -0,0 +1,19 @@+{-# Language OverloadedStrings #-}+module Alto.Example where++import Alto.Compile+import Alto.Menu++exampleMenu :: IO MenuSystem+exampleMenu = compileRoot "Example Menu" $ do+  de <- menu $ ent "Dead end!"+  menu $ do+    ent "This is like a header"+    ent $ "Sub Menu" |-> de+--    ent "A directly defined submenu" $ do+--      ent "This is an entry in a directly defined submenu."+    -- A sometimes hidden menu that+    hideIt <- uniqueTag "Hide it" -- Makes sure the tag isn't used by something else+    ent $ "Hide me!" &- hideIt |-+ hideIt+    ent $ "Unhide it" &+ hideIt |-- hideIt+    ent "Final entry"
+ src/Alto/Menu.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Alto.Menu where++import           Control.Lens+import qualified Control.Monad.Catch as E+import qualified Data.Aeson as JS+import qualified Data.Aeson.TH as JS+import           Data.Aeson (FromJSON, ToJSON)+import           Data.ByteString (ByteString)+import           Data.Char (toLower)+import           Data.Map (Map)+import qualified Data.Map as Map+import           Data.Set (Set)+import           Data.String+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import           System.Directory (listDirectory, createDirectory)+import           System.FilePath+import           GHC.Generics++type MenuID = Text++type Tag = Text++data ClientState =+  ClientState+  { _clientTags :: Map Tag Text+  }+  deriving (Read, Show, Eq, Ord, Generic)++makeLenses ''ClientState+JS.deriveJSON JS.defaultOptions{JS.fieldLabelModifier = drop 7, JS.constructorTagModifier = map toLower} ''ClientState++data TagLogic =+   Always+ | TagSet Tag+ | TagUnset Tag+ | TLAnd [TagLogic]+ | TLOr [TagLogic]+ | TLNot TagLogic+ deriving (Read, Show, Eq, Ord, Generic, ToJSON, FromJSON)++data TagChange =+  TagChange+  { _setTags :: Map Tag Text+  , _unsetTags :: Set Tag+  }+ deriving (Read, Show, Eq, Ord, Generic)++instance Semigroup TagChange where+  (<>) (TagChange a1 a2) (TagChange b1 b2) = TagChange (a1 <> b1) (a2 <> b2)++instance Monoid TagChange where+  mempty = TagChange mempty mempty++makeLenses ''TagChange+JS.deriveJSON JS.defaultOptions{JS.fieldLabelModifier = drop 1, JS.sumEncoding = JS.UntaggedValue} ''TagChange++data EmbedSize =+   EFullPage+ | ENative+ | ESize { _x :: Int, _y :: Int }+ deriving (Read, Show, Eq, Ord, Generic)++makeLenses ''EmbedSize+JS.deriveJSON JS.defaultOptions{JS.fieldLabelModifier = drop 1} ''EmbedSize++data Action =+   ColapseMenu+ | Nav { _url :: Text }+ | Embed { _url :: Text, _size :: EmbedSize }+ | Download { _url :: Text, _filename :: Text }+ | JSCall { _jsCall :: Text }+ deriving (Read, Show, Eq, Ord, Generic)++makeLenses ''Action+JS.deriveJSON JS.defaultOptions{JS.fieldLabelModifier = drop 1} ''Action++data EntryType =+   Action { _onAction :: TagChange, _act :: Maybe Action }+   -- ^ When the entry is clicked it does the above+ | SubMenu { _onAction :: TagChange, _subMenu :: MenuID, _subIdPostfix :: Maybe Tag }+   -- ^ When the entry is selected, the submenu is displayed+ -- | CallBack SomeHMACedThing+ deriving (Read, Show, Eq, Ord, Generic)++makeLenses ''EntryType+JS.deriveJSON JS.defaultOptions{JS.fieldLabelModifier = drop 1} ''EntryType++data MenuEntry =+  MEntry+  { _icon :: Maybe Text+  , _label :: Text+  , _display :: TagLogic+  , _active :: TagLogic+  , _reaction :: EntryType+  }+  deriving (Read, Show, Eq, Ord, Generic)++makeLenses ''MenuEntry+JS.deriveJSON JS.defaultOptions{JS.fieldLabelModifier = drop 1} ''MenuEntry++instance IsString MenuEntry where+  fromString l = MEntry Nothing (T.pack l) Always Always (Action mempty Nothing)++data Menu =+  Menu+  { _mid :: MenuID+  , _onLeave :: TagChange+  , _entries :: [MenuEntry]+  }+  deriving (Read, Show, Eq, Ord, Generic)++makeLenses ''Menu+JS.deriveJSON JS.defaultOptions{JS.fieldLabelModifier = dropWhile (=='m') . drop 1} ''Menu++data Root =+  MenuRoot+  { _rootState :: ClientState+  , _rootMenu :: Menu+  }+  deriving (Read, Show, Eq, Ord, Generic)++makeLenses ''Root+JS.deriveJSON JS.defaultOptions{JS.fieldLabelModifier = drop 5} ''Root++data MenuSystem =+  MenuSystem+  { _menuMap :: Map MenuID Menu+  , _topMenu :: Menu+  }+  deriving (Read, Show, Eq, Ord, Generic, ToJSON, FromJSON)++makeLenses ''MenuSystem++data CompState =+  CSt+  { _salt :: ByteString+    -- ^ A pseudo-salt derived expensively from the overall name. +  , _menus :: Map MenuID Menu+  , _tags :: Set Tag+  }+  deriving (Read, Show, Eq, Ord, Generic)++makeLenses ''CompState++existDirectory :: FilePath -> IO ()+existDirectory fp = E.catch (createDirectory fp) (\(_::E.SomeException) -> return ())++-- | Load a menu from a file+loadMenu :: FilePath -> IO Menu+loadMenu fp = do+  either error return =<< JS.eitherDecodeFileStrict' fp++-- | Loads a MenuSystem directory. The format is:+--   FP:+--     - root <- file containing root menu's ID+--     - menus/ <- directory of one file per menu+loadMenus :: IO MenuSystem+loadMenus = do+  root <- either error return =<< JS.eitherDecodeFileStrict' ("graph" </> "root")+  mns <- (fmap (("graph"</>"menu")</>) <$> listDirectory ("graph" </> "menu")) >>=+         (fmap (Map.fromList . map (\a -> (a ^.mid, a))) . mapM loadMenu)+  return . MenuSystem mns $ root^.rootMenu++-- | Save a MenuSystem so it can be reloaded later for serving or use as a+--   subcomponent of another MenuSystem.+saveMenus :: MenuSystem -> IO ()+saveMenus ms = do+  existDirectory "graph"+  JS.encodeFile ("graph"</>"root") . MenuRoot (ClientState mempty) $ ms^.topMenu+  storeSubMenus ms++storeSubMenus :: MenuSystem -> IO ()+storeSubMenus ms = do+  existDirectory $ "graph" </> "menu"+  ifor_ (ms^.menuMap) $ \i m ->+    JS.encodeFile (("graph"</>"menu")</>(T.unpack i)) m++saveSubGraph :: Text -> MenuSystem -> IO ()+saveSubGraph subname ms = do+  existDirectory "graph"+  storeSubMenus ms+  existDirectory $ "graph" </> "subgraph"+  TIO.writeFile (("graph"</>"subgraph")</>(T.unpack subname)) (ms^.topMenu.mid)++refSubGraph :: Text -> IO Menu+refSubGraph subname = do+  mnId <- TIO.readFile (("graph"</>"subgraph")</>(T.unpack subname))+  loadMenu $ ("graph"</>"menu")</>(T.unpack mnId)
+ src/Alto/Web.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-}+module Alto.Web where++import           Alto.Menu+import           Control.Lens+import           Data.Text (Text)+import           Servant++data AltoConfig =+  AltoConfig+  { _mSys :: MenuSystem+  , _initState :: ClientState+  }+  deriving (Read, Show, Eq, Ord)++makeLenses ''AltoConfig++type RootAPI = "root" :> Get '[JSON] Root+type MenuAPI = "menu" :> Capture "menuid" MenuID :> Get '[JSON] (Headers '[Header "Cache-Control" Text] Menu)+-- type CallbackAPI = "callback" :> ReqBody '[PlainText] ByteString :> Post '[JSON] Event++type API = RootAPI :<|> MenuAPI++api :: Proxy API+api = Proxy++serveRoot :: AltoConfig -> Handler Root+serveRoot cfg = return $ MenuRoot (cfg^.initState) (cfg^.mSys.topMenu)++serveMenu :: AltoConfig -> Text -> Handler Menu+serveMenu cfg i =+  case cfg ^. mSys.menuMap.at i of+    Nothing -> throwError err404+    Just m -> return m++addCacheHeader :: Handler Menu -> Handler (Headers '[Header "Cache-Control" Text] Menu)+addCacheHeader = fmap (addHeader "public, max-age=1")++altoServer :: AltoConfig -> Server API+altoServer cfg = serveRoot cfg :<|> (addCacheHeader <$> serveMenu cfg)++altoApp :: AltoConfig -> Application+altoApp c = serve api (altoServer c)