Initial commit

.gitignore

@@ -0,0 +1,5 @@
+.psci_modules
+.stack-work
+bower_components
+output
+result

backend/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

backend/default.nix

@@ -0,0 +1,51 @@
+{ pkgs ? import <nixpkgs> {}}:
+let
+  haskellPackages = pkgs.haskell.packages.ghc822;
+
+  # Haskell Ide Engine
+  # Pass pkgs to the function since
+  # hie it must use the same ghc
+  hies = import (pkgs.fetchFromGitHub {
+    owner = "domenkozar";
+    repo = "hie-nix";
+    rev = "8f04568aa8c3215f543250eb7a1acfa0cf2d24ed";
+    sha256 = "06ygnywfnp6da0mcy4hq0xcvaaap1w3di2midv1w9b9miam8hdrn";
+  }) {
+    inherit pkgs;
+  };
+
+  # hfmt does not pass its own unit tests right now :(
+  # I'll fix and update this bit later
+  hfmt = haskellPackages.hfmt.overrideAttrs (
+    oldAttrs: {
+      doCheck = false;
+    }
+  );
+
+  devInputs = [
+    hies.hie82
+    hfmt
+  ];
+in
+  with pkgs;
+  pkgs.haskell.lib.buildStackProject {
+    name = "nix-deps";
+    src = lib.sourceFilesBySuffices ./. [
+      ".hs"
+      "grafanix.cabal"
+      "stack.yaml"
+    ];
+    configurePhase = ''
+      export STACK_ROOT=$NIX_BUILD_TOP/.stack
+      for pkg in ''${pkgsHostHost[@]} ''${pkgsHostBuild[@]} ''${pkgsHostTarget[@]}
+      do
+        [ -d "$pkg/lib" ] && \
+          export STACK_IN_NIX_EXTRA_ARGS+=" --extra-lib-dirs=$pkg/lib"
+        [ -d "$pkg/include" ] && \
+          export STACK_IN_NIX_EXTRA_ARGS+=" --extra-include-dirs=$pkg/include"
+      done
+      true
+    '';
+    buildInputs = [ re2 zlib ] ++ 
+      lib.optionals lib.inNixShell devInputs;
+  }

backend/grafanix.cabal

@@ -0,0 +1,45 @@
+name:                grafanix
+version:             0.1.0.0
+author:              Oleh Stolyar
+maintainer:          [email protected]
+copyright:           2018 Oleh Stolyar
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+
+executable main
+  hs-source-dirs:       src
+  main-is:              Main.hs
+  default-language:     Haskell2010
+  other-modules:        Config
+                      , Nix
+                      , Parser
+                      , Types
+  build-depends:        base >= 4.7 && < 5
+                      , aeson
+                      , attoparsec
+                      , bytestring
+                      , containers
+                      , dhall
+                      , errors
+                      , hashable
+                      , lrucaching
+                      , protolude
+                      , re2
+                      , scotty
+                      , text
+                      , typed-process
+                      , wai-middleware-static
+  default-extensions:   DuplicateRecordFields
+                      , DeriveGeneric
+                      , FlexibleContexts
+                      , GeneralizedNewtypeDeriving
+                      , NoImplicitPrelude
+                      , MultiParamTypeClasses
+                      , OverloadedStrings
+                      , RecordWildCards
+                      , ScopedTypeVariables
+                      , StandaloneDeriving
+                      , TupleSections
+                      , TypeApplications
+  ghc-options:        -threaded -rtsopts -with-rtsopts=-N -O2 -Wall

backend/src/Config.hs

@@ -0,0 +1,19 @@
+module Config
+  (Config(..), readConfig)
+where
+
+import Dhall (Interpret, auto, detailed, input)
+import GHC.Generics
+import Protolude
+
+data Config = Config
+  { nixpkgsPath :: Text
+  , staticPath :: Text
+  , duCacheSize :: Integer
+  , whyCacheSize :: Integer
+  } deriving (Show, Generic)
+
+instance Interpret Config
+
+readConfig :: FilePath -> IO Config
+readConfig file = detailed (input auto (toS file))

backend/src/Main.hs

@@ -0,0 +1,38 @@
+module Main where
+
+import           Control.Error                  ( runExceptT )
+import           Data.LruCache.IO               ( newLruHandle )
+import           Protolude               hiding ( get )
+import           Web.Scotty
+import           Network.Wai.Middleware.Static (addBase, staticPolicy)
+
+import           Config (Config(..), readConfig)
+import           Nix
+import           Types (Env(..), runApp)
+
+safeIO :: Script a -> ActionM a
+safeIO script = do
+  result <- liftIO $ runExceptT script
+  case result of
+    Right a   -> return a
+    Left  err -> do
+      putText err
+      raise . toS $ err
+
+main :: IO ()
+main = do
+  config <- readConfig "./config.dhall"
+  duCache <- newLruHandle (fromIntegral . duCacheSize $ config)
+  whyCache <- newLruHandle (fromIntegral . whyCacheSize $ config)
+  let env = Env {..}
+  scotty 3000 $ do
+    middleware $ staticPolicy (addBase . toS $ staticPath config)
+    get "/" $ file . toS $ staticPath config <> "/index.html"
+    get "/deps/:packageName/" $ do
+      pkgName <- param "packageName"
+      deps    <- safeIO $ runApp env $ depTree =<< pkgPath pkgName
+      json deps
+    get "/build-deps/:packageName" $ do
+      pkgName <- param "packageName"
+      deps    <- safeIO $ runApp env $ depTree =<< drvPath pkgName
+      json deps

backend/src/Nix.hs

@@ -0,0 +1,126 @@
+module Nix
+  ( Script
+  , drvPath
+  , pkgPath
+  , depTree
+  )
+where
+
+import           Control.Error                  ( Script
+                                                , scriptIO
+                                                )
+import           Data.Attoparsec.Text           ( Parser
+                                                , parseOnly
+                                                )
+import qualified Data.ByteString.Lazy as L
+import           Data.Hashable                  ( Hashable )
+import           Data.IORef                     ( atomicModifyIORef )
+import           Data.LruCache                  ( insert
+                                                , lookup
+                                                )
+import           Data.LruCache.IO               ( LruHandle(..) )
+import           Data.Tree                      ( Tree(..) )
+import           Data.Text                      ( isSuffixOf
+                                                , strip
+                                                , unwords
+                                                )
+import           Regex.RE2                      ( compile
+                                                , replaceAll
+                                                )
+
+import           System.Environment             ( getEnv )
+import           System.Process.Typed
+import           Protolude
+
+import           Config
+import qualified Parser
+import           Types
+
+decolor :: ByteString -> ByteString
+decolor str = fst $ replaceAll colors str ""
+  where Right colors = compile "\\033\\[(\\d+;)*\\d+m"
+
+run :: Text -> [Text] -> Script ByteString
+run cmd args = do
+  putText cmdline
+  let
+    procConfig = setStdin closed
+               $ setStdout byteStringOutput
+               $ setStderr closed
+               $ proc (toS cmd) (map toS args)
+  (exitCode, out, err) <- readProcess procConfig
+  if exitCode == ExitSuccess
+    then do
+      let decolored = decolor . L.toStrict $ out
+      return decolored
+    else
+      let message = "Command '" <> cmdline <> "' failed with:\n" <> toS err
+      in  throwError message
+  where cmdline = cmd <> " " <> unwords args
+
+cached
+  :: (Hashable k, Ord k) => LruHandle k v -> (k -> Script v) -> k -> Script v
+cached (LruHandle ref) script k = do
+  cachedValue <-
+    scriptIO $ atomicModifyIORef ref $ \cache -> case lookup k cache of
+      Nothing          -> (cache, Nothing)
+      Just (v, cache') -> (cache', Just v)
+  case cachedValue of
+    Just v  -> return v
+    Nothing -> do
+      v <- script k
+      scriptIO $ atomicModifyIORef ref $ \cache -> (insert k v cache, ())
+      return v
+
+parse :: Parser a -> Text -> Script a
+parse parser text = case parseOnly parser text of
+  Right a   -> return a
+  Left  err -> throwError . toS $ err
+
+drvPath :: Text -> App Text
+drvPath pkgName = do
+  nixpkgs <- asks (nixpkgsPath . config)
+  out <- lift $ run "nix-instantiate" [nixpkgs, "--attr", pkgName]
+  lift $ parse Parser.nixPath (toS out)
+
+pkgPath :: Text -> App Text
+pkgPath pkgName = do
+  nixpkgs <- asks (nixpkgsPath . config)
+  out <- lift $ run "nix-build" [nixpkgs, "--attr", pkgName, "--no-out-link"]
+  lift $ parse Parser.nixPath (toS out)
+
+sizeBytes :: Text -> Script Int
+sizeBytes path = do
+  out <- run "du" ["-bs", path]
+  parse Parser.size (toS out)
+
+whyDepends :: (Text, Text) -> Script [Why]
+whyDepends (src, dest) = do
+  out <- run "nix" ["why-depends", toS src, toS dest]
+  parse Parser.whyDepends (toS out)
+
+depTree
+  :: Text
+  -> App DepTree
+depTree path = do
+  out      <- lift $ run "nix-store" ["--query", "--tree", toS path]
+  pathTree <- lift $ parse Parser.depTree (toS out)
+  DepTree <$> mkNodes Nothing pathTree
+ where
+  buildDeps :: Bool
+  buildDeps = ".drv" `isSuffixOf` toS path
+
+  mkNodes :: Maybe Text -> Tree Text -> App (Tree Dep)
+  mkNodes parent Node {..} = do
+    duCache <- asks duCache
+    whyCache <- asks whyCache
+    size        <- lift $ cached duCache sizeBytes rootLabel
+    (sha, name) <- lift $ parse Parser.hashAndName (toS rootLabel)
+    why         <- if buildDeps
+      then return []
+      else case parent of
+        Nothing -> return []
+        Just p  -> lift $ cached whyCache whyDepends (p, rootLabel)
+
+    children <- mapM (mkNodes (Just rootLabel)) subForest
+    return Node {rootLabel = Dep {..}, subForest = children}

backend/src/Parser.hs

@@ -0,0 +1,91 @@
+module Parser where
+
+import           Data.Attoparsec.Text
+import           Data.Char
+import           Data.Tree
+import qualified Data.Text                     as T
+import           Protolude               hiding ( hash
+                                                )
+import           Types
+
+
+parseEither :: Parser a -> Text -> Either Text a
+parseEither parser text = case parseOnly parser text of
+  Right a   -> Right a
+  Left  err -> Left $ toS err
+
+
+restOfLine :: Parser ()
+restOfLine = takeTill isEndOfLine *> endOfLine
+
+
+nixPath :: Parser Text
+nixPath = do
+  store <- string "/nix/store"
+  rest  <- takeTill isSpace
+  return $ store <> rest
+
+
+-- "/nix/store/2kcrj1ksd2a14bm5sky182fv2xwfhfap-glibc-2.26-131"
+-- -> ("2kcrj1ksd2a14bm5sky182fv2xwfhfap", "glibc-2.26-131")
+hashAndName :: Parser (Text, Text)
+hashAndName = do
+  _    <- string "/nix/store/"
+  hash <- takeTill (== '-')
+  _    <- char '-'
+  name <- takeTill isSpace
+  return (hash, name)
+
+
+-- Given the output of `nix-store --query --tree`,
+-- produce a tree of Nix store paths
+depTree :: Parser (Tree Text)
+depTree = do
+  (_, rootLabel) <- node
+  subForest      <- makeForest <$> many node
+  return Node {..}
+ where
+  node :: Parser (Int, Text)
+  node = do
+    indent <- takeTill (== '/')
+    label  <- takeWhile1 (not . isSpace) <* restOfLine
+    let level = T.length indent `div` 4
+    return (level, label)
+
+  makeForest :: [(Int, Text)] -> [Tree Text]
+  makeForest [] = []
+  makeForest ((level, label) : xs) =
+    let
+      (children, rest) = break (\(x, _) -> x <= level) xs
+    in
+      case children of
+        [] -> []
+        _ -> [ Node {rootLabel = label, subForest = makeForest children} ]
+        ++ makeForest rest
+
+
+-- Given the output of `nix why-depends --all $from $to`,
+-- produce a list of reasons why `from` directly depends on `to`.
+-- The output of `why-depends` will print the shortest paths first,
+-- which is why we only need to parse the first level of indentation until
+-- the first "=> "
+whyDepends :: Parser [Why]
+whyDepends = do
+  restOfLine
+  many why
+ where
+    -- `filepath:…reason…` => Why
+  why :: Parser Why
+  why = do
+    skipWhile isIndent
+    file   <- takeTill (== ':') <* takeTill (== '…') <* char '…'
+    reason <- takeTill (== '…')
+    restOfLine
+    return Why {..}
+
+  isIndent :: Char -> Bool
+  isIndent c = c == ' ' || c == '║' || c == '╠' || c == '╚' || c == '═'
+
+
+size :: Parser Int
+size = decimal