module Teleport where
import Control.Lens hiding (argument)
import Control.Monad
import Data.Binary
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Composition
import Data.Default
import Data.List
import Data.Maybe
import Data.Monoid
import qualified Data.Text as T
import Data.Text.Encoding
import Data.Version
import Filesystem as P
import qualified Filesystem.Path.CurrentOS as P
import GHC.Generics
import Options.Applicative
import Paths_shift
import Prelude hiding (FilePath)
import System.Console.ANSI
import System.Environment
import Turtle hiding (find, header)
data AddOptions = AddOptions { folderPath :: Maybe String,
addname :: String }
newtype RemoveOptions = RemoveOptions { removename :: String }
newtype GotoOptions = GotoOptions { gotoname :: String }
data Command = Display | Add AddOptions | Remove RemoveOptions | Goto GotoOptions
data WarpPoint = WarpPoint { _name :: String,
_absFolderPath :: String } deriving (Default, Generic, Binary)
newtype WarpData = WarpData { _warpPoints :: [WarpPoint] } deriving (Default, Generic, Binary)
makeLenses ''WarpData
makeLenses ''WarpPoint
exec :: IO ()
exec = execParser opts >>= run
where versionInfo = infoOption ("teleport version: " ++ showVersion version) (short 'v' <> long "version" <> help "Show version")
opts = info (helper <*> versionInfo <*> parseCommand)
(fullDesc
<> progDesc "use warp to quickly setup warp points and move between them"
<> header "Warp: move around your filesystem")
decodeWarpData :: FilePath -> IO WarpData
decodeWarpData = fmap decode . (fmap BSL.fromStrict . BS.readFile) . P.encodeString
loadWarpData :: FilePath -> IO WarpData
loadWarpData configFilePath = testfile configFilePath >>= \exists ->
if exists then decodeWarpData configFilePath
else saveWarpData configFilePath def >> pure def
saveWarpData :: FilePath -> WarpData -> IO ()
saveWarpData configFilePath warpData =
let dataBytestring = encode warpData in
BSL.writeFile (P.encodeString configFilePath) dataBytestring
warpDataPath :: IO FilePath
warpDataPath = home >>= \homeFolder ->
pure (homeFolder </> ".warpdata")
readFolderPath :: String -> ReadM FilePath
readFolderPath = f . fromText . T.pack
where f path = if P.valid path then pure path else readerError ("invalid path: " <> show path)
warpnameParser :: Parser String
warpnameParser = argument str
(metavar "NAME"
<> help "name of the warp point")
parseAddCommand :: Parser Command
parseAddCommand = Add .* AddOptions <$> folderParser <*> warpnameParser
folderParser :: Parser (Maybe String)
folderParser = optional $ strOption
(long "path"
<> short 'p'
<> metavar "FOLDER"
<> help "path to the folder to warp to")
parseRemoveCommand :: Parser Command
parseRemoveCommand = Remove . RemoveOptions <$> warpnameParser
parseGotoCommand :: Parser Command
parseGotoCommand = Goto . GotoOptions <$> warpnameParser
parseCommand :: Parser Command
parseCommand = hsubparser
(command "add" (info parseAddCommand (progDesc "add a warp point"))
<> (command "list" (info (pure Display) (progDesc "list all warp points")))
<> (command "del" (info parseRemoveCommand (progDesc "delete a warp point")))
<> (command "to" (info parseGotoCommand (progDesc "go to a created warp point"))))
setErrorColor :: IO ()
setErrorColor = setSGR [SetColor Foreground Vivid Red]
colorWhen :: IO () -> IO ()
colorWhen act = do
useColor <- fromMaybe "1" <$> lookupEnv "CLICOLOR"
if useColor /= "0" then act else pure def
warpPointPrint :: WarpPoint -> IO ()
warpPointPrint warpPoint = do
colorWhen $ setSGR [SetColor Foreground Dull White]
putStr (_name warpPoint)
colorWhen $ setSGR [SetColor Foreground Vivid Blue]
putStr $ "\t" <> _absFolderPath warpPoint <> "\n"
folderNotFoundError :: FilePath -> IO ()
folderNotFoundError path = setErrorColor >>
(die . T.pack $ ("unable to find folder: " ++ show path))
needFolderNotFileError :: FilePath -> IO ()
needFolderNotFileError path = setErrorColor >>
(die . T.pack $ "expected folder, not file: " ++ show path)
dieIfFolderNotFound :: FilePath -> IO ()
dieIfFolderNotFound path = foldr (>>) (pure def)
[ flip when (needFolderNotFileError path) =<< testfile path
, flip unless (folderNotFoundError path) =<< testdir path ]
dieWarpPointExists :: WarpPoint -> IO ()
dieWarpPointExists warpPoint = foldr (>>) (pure def)
[ setErrorColor
, putStrLn $ "warp point " <> _name warpPoint <> " already exists:\n"
, warpPointPrint warpPoint ]
runAdd :: AddOptions -> IO ()
runAdd AddOptions{..} = do
dieIfFolderNotFound . P.decode . encodeUtf8 . T.pack . fromMaybe "./" $ folderPath
print "folder exists, loading warp data..."
warpData <- loadWarpData =<< warpDataPath
_absFolderPath <- realpath . P.decode . encodeUtf8 . T.pack . fromMaybe "./" $ folderPath
let existingWarpPoint = find ((==addname) . _name) (_warpPoints warpData)
case existingWarpPoint of
Just warpPoint -> dieWarpPointExists warpPoint
Nothing -> do
putStrLn "creating warp point: \n"
let newWarpPoint = def & name .~ addname & absFolderPath .~ P.encodeString _absFolderPath
warpPointPrint newWarpPoint
let newWarpData = over warpPoints (newWarpPoint:) warpData
flip saveWarpData newWarpData =<< warpDataPath
runDisplay :: IO ()
runDisplay = do
warpData <- loadWarpData =<< warpDataPath
forM_ (_warpPoints warpData) warpPointPrint
dieWarpPointNotFound :: String ->IO ()
dieWarpPointNotFound w = setErrorColor >> (die . T.pack)
(w <> " warp point not found")
runRemove :: RemoveOptions -> IO ()
runRemove RemoveOptions{..} = do
warpPath <- warpDataPath
warp <- loadWarpData warpPath
let wantedWarpPoint = find ((/= removename) . _name) (_warpPoints warp)
case wantedWarpPoint of
Nothing -> dieWarpPointNotFound removename
Just _ -> saveWarpData warpPath
(over warpPoints (filter ((/= removename) . _name)) warp)
runGoto :: GotoOptions -> IO ()
runGoto GotoOptions{..} = do
warpPath <- warpDataPath
warp <- loadWarpData warpPath
let wantedWarpPoint = find ((== gotoname) . _name) (_warpPoints warp)
case wantedWarpPoint of
Nothing -> dieWarpPointNotFound gotoname
Just warpPoint -> do
echo (unsafeTextToLine . T.pack . _absFolderPath $ warpPoint)
cd . fromString $ _absFolderPath warpPoint
setWorkingDirectory . fromString . _absFolderPath $ warpPoint
exit (ExitFailure 2)
run :: Command -> IO ()
run (Add addOpt) = runAdd addOpt
run Display = runDisplay
run (Remove removeOpt) = runRemove removeOpt
run (Goto gotoOpt) = runGoto gotoOpt