Initial commit
This commit is contained in:
183
src/Main.hs
Normal file
183
src/Main.hs
Normal file
@@ -0,0 +1,183 @@
|
||||
module Main (main) where
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Data.Functor
|
||||
import Data.List (isInfixOf, isSuffixOf)
|
||||
import System.Directory (listDirectory)
|
||||
import System.Environment (getArgs, getEnv)
|
||||
import System.IO
|
||||
import System.IO.Error
|
||||
|
||||
-- Constants
|
||||
defaultOutfile :: String
|
||||
defaultOutfile = "LICENSE"
|
||||
|
||||
defaultSystemLicenseDir :: String
|
||||
defaultSystemLicenseDir = "/usr/share/license-tool"
|
||||
|
||||
defaultUserLicenseRelDir :: String
|
||||
defaultUserLicenseRelDir = ".config/license-tool"
|
||||
|
||||
-- Argument parsing
|
||||
data SearchMode = SystemOnly | UserOnly | UserThenSystem
|
||||
|
||||
data ArgumentResult
|
||||
= License String SearchMode (Maybe String) -- outfile search dirs name
|
||||
| Help
|
||||
| List
|
||||
| Error String -- msg
|
||||
|
||||
missingValue :: Char -> ArgumentResult
|
||||
missingValue flag = Error $ "flag '" ++ [flag] ++ "' requires a value"
|
||||
|
||||
parseArgs :: [String] -> ArgumentResult
|
||||
parseArgs = parseArgs' True (License defaultOutfile UserThenSystem Nothing)
|
||||
where
|
||||
parseArgs' :: Bool -> ArgumentResult -> [String] -> ArgumentResult
|
||||
-- help
|
||||
parseArgs' True _ (('-' : 'h' : _) : _) = Help
|
||||
-- list
|
||||
parseArgs' True _ (('-' : 'l' : _) : _) = List
|
||||
-- outfile
|
||||
parseArgs' True (License _ sm name) (('-' : 'o' : outfile@(_ : _)) : rest) =
|
||||
parseArgs' True (License outfile sm name) rest
|
||||
parseArgs' True (License _ sm name) ("-o" : outfile : rest) =
|
||||
parseArgs' True (License outfile sm name) rest
|
||||
parseArgs' True _ ["-o"] = missingValue 'o'
|
||||
-- search paths
|
||||
parseArgs' True (License outfile _ name) (('-' : 'u' : flags) : rest) =
|
||||
parseArgs' True (License outfile UserOnly name) (("-" ++ flags) : rest)
|
||||
parseArgs' True (License outfile _ name) (('-' : 's' : flags) : rest) =
|
||||
parseArgs' True (License outfile SystemOnly name) (("-" ++ flags) : rest)
|
||||
-- empty flag
|
||||
parseArgs' True state ("-" : rest) = parseArgs' True state rest
|
||||
-- no more flags
|
||||
parseArgs' True (License outfile sm Nothing) ("--" : name : rest) =
|
||||
parseArgs' False (License outfile sm (Just name)) rest
|
||||
-- unknown flag
|
||||
parseArgs' True _ (('-' : flag : _) : _) =
|
||||
Error $ "unknown flag: '-" ++ [flag] ++ "'"
|
||||
-- license
|
||||
parseArgs' doFlags (License outfile sm Nothing) (name : rest) =
|
||||
parseArgs' doFlags (License outfile sm (Just name)) rest
|
||||
parseArgs' _ (License _ _ (Just _)) (_ : _) =
|
||||
Error "extra junk after license name"
|
||||
-- base
|
||||
parseArgs' _ state _ = state
|
||||
|
||||
-- Modes
|
||||
normalizeDirectory :: String -> String
|
||||
normalizeDirectory s = if "/" `isSuffixOf` s then s else s ++ "/"
|
||||
|
||||
userLicenseDir :: IO String
|
||||
userLicenseDir = userHomeDir <&> (++ defaultUserLicenseRelDir)
|
||||
where
|
||||
userHomeDir :: IO String
|
||||
userHomeDir = getEnv "HOME" <&> normalizeDirectory
|
||||
|
||||
writeLicense :: String -> SearchMode -> String -> IO ()
|
||||
writeLicense outfile sm name = do
|
||||
paths <- searchPathList sm
|
||||
content <- try (readLicense paths) :: IO (Either IOError String)
|
||||
case content of
|
||||
Left e -> printReadError e
|
||||
Right text -> catch (writeFile outfile text) printWriteError
|
||||
where
|
||||
printWriteError :: IOError -> IO ()
|
||||
printWriteError e =
|
||||
let
|
||||
msg = ioeGetErrorString e
|
||||
in
|
||||
hPutStrLn stderr $ "error: writing " ++ outfile ++ ": " ++ msg
|
||||
|
||||
printReadError :: IOError -> IO ()
|
||||
printReadError e
|
||||
| isDoesNotExistError e =
|
||||
hPutStrLn stderr $ "error: license " ++ name ++ " does not exist"
|
||||
| otherwise =
|
||||
let
|
||||
msg = ioeGetErrorString e
|
||||
in
|
||||
case ioeGetFileName e of
|
||||
Just path -> hPutStrLn stderr $ "error: " ++ path ++ ": " ++ msg
|
||||
Nothing ->
|
||||
hPutStrLn stderr $ "error: reading " ++ name ++ ": " ++ msg
|
||||
|
||||
readLicense :: [String] -> IO String
|
||||
readLicense sp = do
|
||||
res <- readLicense' Nothing sp
|
||||
case res of
|
||||
Left e -> throwIO e
|
||||
Right c -> return c
|
||||
where
|
||||
readLicense' :: Maybe IOError -> [String] -> IO (Either IOError String)
|
||||
readLicense' (Just lastError) [] = return $ Left lastError
|
||||
readLicense' _ (dir : rest) = do
|
||||
content <-
|
||||
try (openBinaryFile (dir ++ name) ReadMode >>= hGetContents) ::
|
||||
IO (Either IOError String)
|
||||
case content of
|
||||
Left e | isDoesNotExistError e -> readLicense' (Just e) rest
|
||||
r -> return r
|
||||
-- shouldn't happen as if we failed, it was because of an error
|
||||
readLicense' Nothing [] = error "Main.readLicense'"
|
||||
|
||||
searchPathList :: SearchMode -> IO [String]
|
||||
searchPathList UserOnly = userLicenseDir <&> ((: []) . normalizeDirectory)
|
||||
searchPathList SystemOnly = return [normalizeDirectory defaultSystemLicenseDir]
|
||||
searchPathList UserThenSystem =
|
||||
liftA2 (++) (searchPathList UserOnly) (searchPathList SystemOnly)
|
||||
|
||||
printHelp :: IO ()
|
||||
printHelp = do
|
||||
putStrLn "usage: license-tool [-u] [-s] [-o OUTFILE] <LICENSE>"
|
||||
putStrLn " license-tool [-h | -l]"
|
||||
putStrLn " -h Print this message, then exit"
|
||||
putStrLn " -l List all known licenses, then exit"
|
||||
putStrLn $
|
||||
" -o Specify file to write license to (default: " ++ defaultOutfile ++ ")"
|
||||
putStrLn " -u Only search user licenses"
|
||||
putStrLn " -s Only search system licenses"
|
||||
|
||||
listLicenses :: IO ()
|
||||
listLicenses = do
|
||||
hadSystem <- printLicenseDir "System" defaultSystemLicenseDir
|
||||
homeDir <- userLicenseDir
|
||||
hadUser <- printLicenseDir "User" homeDir
|
||||
unless (hadSystem || hadUser) $
|
||||
do
|
||||
hPutStrLn stderr "Unable to read both system and user license dir"
|
||||
hPutStrLn stderr $ "System: " ++ show defaultSystemLicenseDir
|
||||
hPutStrLn stderr $ "User: " ++ show homeDir
|
||||
where
|
||||
printLicenseDir :: String -> String -> IO Bool
|
||||
printLicenseDir name dir = do
|
||||
res <- try (listDirectory dir) :: IO (Either IOError [String])
|
||||
case res of
|
||||
Right files -> do
|
||||
putStrLn $ name ++ " license dir:"
|
||||
mapM_ (putStrLn . (" - " ++)) files
|
||||
return True
|
||||
Left _ -> return False
|
||||
|
||||
handleArgError :: String -> IO ()
|
||||
handleArgError msg = hPutStrLn stderr $ "error: " ++ msg
|
||||
|
||||
isValidLicenseName :: String -> Bool
|
||||
isValidLicenseName ".." = False
|
||||
isValidLicenseName "." = False
|
||||
isValidLicenseName name = not ("/" `isInfixOf` name)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
case parseArgs args of
|
||||
License outfile sm (Just name) ->
|
||||
if isValidLicenseName name
|
||||
then writeLicense outfile sm name
|
||||
else handleArgError "illegal license name"
|
||||
License _ _ Nothing -> handleArgError "no license specified"
|
||||
Help -> printHelp
|
||||
List -> listLicenses
|
||||
Error msg -> handleArgError msg
|
||||
Reference in New Issue
Block a user