dmenu-pmount (empty) → 0.1.0.0

raw patch · 5 files changed

+305/−0 lines, 5 filesdep +basedep +containersdep +directorybuild-type:Customsetup-changedbinary-added

Dependencies added: base, containers, directory, dmenu, lens, mtl, process, transformers

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• dmenu-pmount.cabal +57/−0
• doc/dmenu-pmount.png binary
• src/Main.hs +216/−0

@@ -0,0 +1,30 @@+Copyright Author name here (c) 2016++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 Author name here 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.

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

@@ -0,0 +1,57 @@+name:+  dmenu-pmount+version:+  0.1.0.0+synopsis:+  Mounting and unmounting linux devices as user with dmenu and pmount.+description:+  See README.md file.+homepage:+  https://github.com/m0rphism/haskell-dmenu-pmount+bug-reports:+  https://github.com/m0rphism/haskell-dmenu-pmount/issues+license:+  BSD3+license-file:+  LICENSE+author:+  Hannes Saffrich+maintainer:+  Hannes Saffrich <m0rphism@zankapfel.org>+copyright:+  2016 Hannes Saffrich+category:+  System+build-type:+  Custom+cabal-version:+  >=1.10+extra-doc-files:+  doc/*.png+stability:+  Beta+tested-with:+  GHC == 8.0.1++executable dmenu-pmount+  hs-source-dirs:+    src+  default-language:+    Haskell2010+  main-is:+    Main.hs+  build-depends:+    base >= 4.8 && < 5,+    containers >= 0.5.7 && < 0.6,+    lens >= 4.10 && < 4.16,+    mtl >= 2.2 && < 2.3,+    transformers >= 0.5 && < 0.6,+    process >= 1.4 && < 1.5,+    directory >= 1.2.6 && < 1.3,+    dmenu >= 0.3.1 && < 0.4+  ghc-options:+    -Wall -threaded -O2 -fno-warn-partial-type-signatures++source-repository head+  type: git+  location: https://github.com/m0rphism/haskell-dmenu-pmount.git

binary file changed (absent → 9562 bytes)

@@ -0,0 +1,216 @@+{-# LANGUAGE UnicodeSyntax, LambdaCase, ScopedTypeVariables, FlexibleContexts #-}++module Main where++import Control.Monad+import Control.Monad.State+import Control.Lens+import Text.Read (readMaybe)+import System.Directory+import System.Environment+import System.Exit+import System.Process+import Control.Exception+import Data.Maybe+import Data.List (isPrefixOf, sort)++import qualified DMenu++-- | List the files in a directory or the empty list in case of an exception.+listDirectoryDef+  :: MonadIO m+  => FilePath+  -> m [FilePath]+listDirectoryDef p =+  liftIO $ fmap sort $+    listDirectory p `catch` (\(_ :: SomeException) -> pure [])++-- | Return all files in the /dev/ directory.+getDevs+  :: MonadIO m+  => m [FilePath]+getDevs =+  liftIO $ listDirectoryDef "/dev"++-- | Run a process.+runProc+  :: MonadIO m+  => String   -- ^ Program name+  -> [String] -- ^ Program arguments+  -> String   -- ^ Input piped into @stdin@+  -> m (Either String String) -- ^ Either the @stderr@ output, if the process failed, or the @stdout@ output.+runProc prog args sIn =+  liftIO $ do+    (exitCode, sOut, sErr) ←+      readCreateProcessWithExitCode (proc prog args) sIn+    pure $ case exitCode of+      ExitSuccess   → Right sOut+      ExitFailure _ → Left sErr++-- | Run a process.+runProcOr+  :: MonadIO m+  => String   -- ^ Program name+  -> [String] -- ^ Program arguments+  -> String   -- ^ Input piped into @stdin@+  -> String   -- ^ Default value, returned if process exits with failure+  -> m String -- ^ Either the default value, or the @stdout@ output of the process+runProcOr prog args sIn sDef =+  either (const sDef) id <$> runProc prog args sIn++-- | Keep 'String's which have certain prefixes.+filterWithPrefixes+  :: [String] -- ^ List of prefixes+  -> [String] -- ^ List of 'String's to filter+  -> [String] -- ^ 'String's which have one of the prefixes as prefix.+filterWithPrefixes = \case+  [] -> id+  ps -> filter $ \s → any (`isPrefixOf` s) ps++-- | Drop an amount of number substrings separated by whitespace from a string.+skipNumbersAndWS+  :: Int -- ^ How many numbers to skip+  -> String+  -> String+skipNumbersAndWS =+  go False+ where+  go _ 0 s                           = dropWhile (`elem` [' ', '\t']) $ s+  go _ _ ""                          = ""+  go b n (c:s) | c `elem` ['0'..'9'] = go True n s+               | otherwise           = go False (if b then n-1 else n) s++-- | Display a byte size as 'String'.+showBytes+  :: Integer -- ^ Number of bytes for @1 KB@. Usually @1024@ or @1000@.+  -> Integer -- ^ Number of bytes to display as 'String'.+  -> String+showBytes k i+  | i < k         = show i ++ " B"+  | i < k*k       = show (i `div` k) ++ " KB"+  | i < k*k*k     = show (i `div` (k*k)) ++ " MB"+  | i < k*k*k*k   = show (i `div` (k*k*k)) ++ " GB"+  | i < k*k*k*k*k = show (i `div` (k*k*k*k)) ++ " TB"+  | otherwise     = show (i `div` (k*k*k*k*k)) ++ " PB"++-- | Run @cat /proc/partitions@ and collect info about the capacities of+-- storage devices.+getPartitionInfos+  :: MonadIO m+  => m [(FilePath, Integer)] -- ^ Map from device name to @String@ representation of it's capacity.+getPartitionInfos = do+  sOut ← runProcOr "cat" ["/proc/partitions"] "" ""+  forM (drop 2 $ lines sOut) $ \l → do+    let numBlocks :: Integer = read $ head $ words $ skipNumbersAndWS 2 l+    let devPath = head (words $ skipNumbersAndWS 3 l)+    pure (devPath, numBlocks * 1024)++-- | Make all @String@s in a list have the same size, by filling missing+-- characters with spaces from the right.+fillWithSpR+  :: [String]+  -> [String]+fillWithSpR ss =+  map f ss+ where+  f s = s ++ replicate (maxLength - length s) ' '+  maxLength = maximum (map length ss)++-- | Make all @String@s in a list have the same size, by filling missing+-- characters with spaces from the left.+fillWithSpL+  :: [String]+  -> [String]+fillWithSpL ss =+  map f ss+ where+  f s = replicate (maxLength - length s) ' ' ++ s+  maxLength = maximum (map length ss)++-- | Spawn a @pmount@ process and retrieve a list of currently mounted devices.+getMountedDevs+  :: MonadIO m+  => m [FilePath]+getMountedDevs =+  liftIO $ do+    (exitCode, sOut, _sErr) <- readCreateProcessWithExitCode+      (proc "pmount" []) ""+    pure $ case exitCode of+      ExitSuccess   → map ((!! 0) . words) $ drop 1 $ init $ lines sOut+      ExitFailure _ → []++-- | Parse the command line arguments+readArgs+  :: [String] -- ^ Arguments from 'getArgs'+  -> IO (Bool, [String], Integer) -- ^ (1) Whether the unmount flag was set, (2) a list of device prefixes to filter for, (3) how much byte are 1 KB.+readArgs args =+  execStateT (go $ words $ unwords args) (False, [], 1024)+ where+  go [] =+    pure ()+  go (a:as)+    -- All arguments after "--" are passed to dmenu later.+    | a == "--" =+      pure ()+    | a `elem` ["-f", "--filter"] = do+      let (prefixes, as') = break ("-" `isPrefixOf`) as+      _2 %= (++prefixes)+      go as'+    | a `elem` ["-u", "--unmount"] = do+      _1 .= True+      go as+    | a `elem` ["-k", "--kilo"]+    , a':as' <- as+    , Just k <- readMaybe a'+    , k > 0 = do+      _3 .= k+      go as'+    | a `elem` ["-h", "--help"] =+      liftIO $ do putStrLn usage; exitFailure+    | a == "" =+      go as+  go _ =+    liftIO $ do+      putStrLn usage+      exitFailure++main+  :: IO ()+main = do+  (unmount, prefixes, k) <- readArgs =<< getArgs+  let (prog, devsM) | unmount = ("pumount", map (drop 5) . filterWithPrefixes (map ("/dev/"++) prefixes) <$> getMountedDevs)+                    | otherwise = ("pmount", filterWithPrefixes prefixes <$> getDevs)+  devs ← devsM+  devInfos ← map (_2 %~ showBytes k) <$> getPartitionInfos+  let devInfos' = map (fromMaybe "" . flip lookup devInfos) devs+  let devs' = zip devs $ zipWith (\x y → x++"  "++y) (fillWithSpR devs) (fillWithSpL devInfos')+  let dmenuOpts = do+        DMenu.prompt .= drop 1 prog+        DMenu.forwardExtraArgs+  DMenu.selectWith dmenuOpts snd devs' >>= \case+    Right (dev,_) | not (null dev) → callProcess prog [dev]+    _                              → pure ()++usage+  :: String+usage =+  unlines+    [ "USAGE"+    , "  dmenu-pmount [OPTIONS] [-- DMENUOPTIONS]"+    , ""+    , "  Mount or unmount a linux device with dmenu and pmount as user."+    , ""+    , "  All arguments, after the first `--` argument, are directly passed to dmenu."+    , ""+    , "OPTIONS"+    , "  -u, --unmount"+    , "    Unmount devices displayed by `pmount` with `pumount`."+    , "  -f, --filter <DevPrefixList>"+    , "    Only display devices whose filenames have a certain prefix."+    , "    Example: `dmenu-pmount -f sd cdrom` only displays devices beginning with"+    , "             `sd` or `cdrom`, e.g. `/dev/sda2`."+    , "  -k, --kilo <Natural>"+    , "    How much byte are represented by 1 KB? Usually 1024 (default) or 1000."+    , "  -h, --help"+    , "    Display this message."+    ]