diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, João Cristóvão + +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 João Cristóvão 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/System/Util.hs b/src/System/Util.hs new file mode 100644 --- /dev/null +++ b/src/System/Util.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE CPP #-} + +module System.Util + ( isRW + , isExe + , exeExists + , getShellExe + , getXdgConfigFolder + , getDotConfigFolder + , getHomeFolder + , getCurrFolder + , getCustomFolder + , checkOrCreate + , tidleExp + , normFilePath + , getDefaultShell + ) where + +import Prelude +import Data.Semigroup + +import System.Lifted +import System.Directory.Lifted +import System.Environment.Lifted +import System.Posix.User.Lifted +import System.FilePath +import System.IO.Error +import GHC.IO.Exception + +import Control.Monad.Trans.Either +import Control.Applicative + +------------------------------------------------------------------------------ +-- Text Utils ---------------------------------------------------------------- +------------------------------------------------------------------------------ + +type EitherIOException = EitherT IOException + +deriveSystemLiftedErrors "DisallowIOE [HardwareFault]" ''EitherIOException +deriveSystemDirectory ''EitherIOException +deriveSystemEnvironment ''EitherIOException +deriveSystemPosixUser ''EitherIOException + +isRW :: FilePath -> EitherT IOException IO FilePath +isRW path = do + perm <- getPermissions path + if readable perm && writable perm + then right path + else left $ mkIOError PermissionDenied + "Missing read/write permissions" + Nothing (Just path) + +isExe :: FilePath -> EitherT IOException IO FilePath +isExe path = do + perm <- getPermissions path + if executable perm + then right path + else left $ mkIOError PermissionDenied + "Missing executable permissions" + Nothing (Just path) + +doesNotExist :: String -> IOError +doesNotExist str = mkIOError doesNotExistErrorType str + Nothing Nothing + +-- this could receive a path relative to the current directory or +-- the executable name (in the path). +exeExists :: FilePath -> EitherT IOException IO FilePath +exeExists path = joinMET (doesNotExist "Executable not found") + $ bimapEitherT id Just (isExe path) + <> findExecutable path + +-- | Check if a executable pointed by the given environement +-- variable exists, and is executable. +getShellExe :: FilePath -> EitherT IOException IO FilePath +getShellExe var = do + exe <- joinMET ( doesNotExist ( "Variable " + <> var + <> " not found in current environment") + ) + $ lookupEnv var + exeExists exe + +-- | Get configuration folder +-- http://stackoverflow.com/a/1024339/516184 +getXdgConfigFolder :: EitherT IOException IO FilePath +getXdgConfigFolder = isRW =<< getEnv "XDG_CONFIG_HOME" + +getDotConfigFolder :: EitherT IOException IO FilePath +getDotConfigFolder = do + home <- isRW =<< getHomeDirectory + isRW $ home ".config" + +getHomeFolder :: EitherT IOException IO FilePath +getHomeFolder = isRW =<< getHomeDirectory + +getCurrFolder :: EitherT IOException IO FilePath +getCurrFolder = isRW "." + +getCustomFolder :: Maybe FilePath -> EitherT IOException IO FilePath +getCustomFolder fp = case fp of + Nothing -> left . userError $ "No path provided" + Just fp' -> do + dirExists <- doesDirectoryExist fp' + if dirExists + then isRW fp' + else left $ mkIOError NoSuchThing "Invalid path provided" + Nothing (Just fp') + +-- | Check if a given directory exists, and if it features Read/Write permissions. +-- If it does not exist, create it. +checkOrCreate :: FilePath -> EitherT IOException IO FilePath +checkOrCreate path = createDirectoryIfMissing True path >> isRW path + +-- | Perform tidle expansion so that @~ = $HOME@. +-- It does not handle tidle as $HOME in other places besides first caracter +-- in FilePath +tidleExp :: FilePath -> EitherT IOException IO FilePath +tidleExp fp = do + home <- getHomeFolder + right $ case fp of + "" -> "" + (x:xs) -> case x of + '~' -> case xs of + [] -> home + (y:ys) -> if isPathSeparator y then home ys else x:xs + _ -> x:xs + +normFilePath :: FilePath -> EitherT IOException IO FilePath +normFilePath fp + = makeValid . normalise <$> (canonicalizePath =<< tidleExp fp) + + +-- | Determine system shell: best effort. Tries @$SHELL@ variable first, +-- then POSIX shell user entry, than in a last effort @/bin/sh@. +getDefaultShell :: EitherT IOException IO FilePath +getDefaultShell = envShell <> nixShell <> wtfShell + where + envShell = getEnv "SHELL" + nixShell = fmap userShell $ getUserEntryForID =<< getRealUserID + wtfShell = joinMET (mkIOError NoSuchThing "No shell found!" Nothing Nothing) + $ findExecutable "/bin/sh" diff --git a/system-util.cabal b/system-util.cabal new file mode 100644 --- /dev/null +++ b/system-util.cabal @@ -0,0 +1,53 @@ +name: system-util +version: 0.2 +license: BSD3 +license-file: LICENSE +author: João Cristóvão +maintainer: jmacristovao@gmail.com +synopsis: Various system utils lifted to EitherT +description: Various system functions lifted to EitherT. + Provides higher level functions to those in system-lifted. +category: System +cabal-version: >= 1.16 +build-type: Simple +homepage: https://github.com/jcristovao/system-util + +library + exposed-modules: System.Util + build-depends: base >= 4 && < 5 + , transformers >= 0.3 && < 0.5 + , template-haskell >= 2.5 && < 2.10 + , either >= 4.1.1 && < 4.3 + , semigroups >= 0.13 && < 0.15 + , unix >= 2.6 && < 2.8 + , directory >= 1.2.0.1 && < 1.3 + , filepath >= 1.3.0.1 && < 1.4 + , system-lifted >= 0.2.0.1 && < 0.3 + + hs-source-dirs: src + ghc-options: -Wall + default-language: Haskell2010 + + + +test-suite test + type: exitcode-stdio-1.0 + main-is: main.hs + hs-source-dirs: test,src + build-depends: base >= 4 && < 5 + , transformers >= 0.3 + , template-haskell >= 2.5 + , either >= 4.1.1 + , semigroups >= 0.13 && < 0.15 + , quickcheck-instances >= 0.3.6 + , hspec >= 1.7.2 + , directory >= 1.2.0.1 + , easy-data >= 0.2 + , system-lifted >= 0.2.0 + , filepath >= 1.3.0.1 + + default-language: Haskell2010 + +--source-repository head + --type: git + --location: https://github.com/jcristovao/migrationplus diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +