hasufell/hsfm
1
1
Fork 0
Code Issues 33 Pull Requests Releases Wiki Activity

Compare commits

base: hasufell:master
Branches Tags
hasufell:master
hasufell:gh-pages
hasufell:travis
hasufell:development
hasufell:bookmarks
hasufell:docfix
hasufell:develop
..
compare: hasufell:development
Branches Tags
hasufell:master
hasufell:gh-pages
hasufell:travis
hasufell:development
hasufell:bookmarks
hasufell:docfix
hasufell:develop

No commits in common. "master" and "development" have entirely different histories.
master ... developmen

154 changed files with 3453 additions and 1654 deletions
Show Stats Expand all files Collapse all files

21
.gitignore vendored
View File

@ -1,15 +1,8 @@
*.hp
*.old
*.prof
*~
.cabal-sandbox/
.ghc.environment.*
.liquid/
.stack-work/
3rdparty/hpath
cabal.sandbox.config
dist-newstyle/
dist/ dist/
hscope.out .cabal-sandbox/
.ghcup cabal.sandbox.config
/bin/ *~
*.hp
*.prof
*.old
.liquid/

6
.gitmodules vendored Normal file
View File

@ -0,0 +1,6 @@
[submodule "3rdparty/hpath"]
path = 3rdparty/hpath
url = https://github.com/hasufell/hpath.git
[submodule "3rdparty/simple-sendfile"]
path = 3rdparty/simple-sendfile
url = https://github.com/hasufell/simple-sendfile.git

68
.travis.yml
View File

@ -1,68 +0,0 @@
# See https://github.com/hvr/multi-ghc-travis for more information
language: c
sudo: required
dist: trusty
matrix:
include:
- env: CABALVER=1.24 GHCVER=8.0.1
addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}
- env: CABALVER=2.0 GHCVER=8.2.2
addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}}
- env: CABALVER=2.2 GHCVER=8.4.1
addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.1], sources: [hvr-ghc]}}
- env: CABALVER=head GHCVER=head
addons: {apt: {packages: [cabal-install-head,ghc-head,libgtk2.0-dev,libgtk-3-dev], sources: [hvr-ghc]}}
allow_failures:
- env: CABALVER=head GHCVER=head
env:
global:
- secure: "qAzj5tgAghFIfO6R/+Hdc5KcFhwXKNXMICNH7VLmqLzmYxk1UEkpi6hgX/f1bP5mLd07D+0IaeGFIUIWQOp+F/Du1NiX3yGbFuTt/Ja4I0K4ooCQc0w9uYLv8epxzp3VEOEI5sVCSpSomFjr7V0jwwTcBbxGUvv1VaGkJwAexRxCHuwU23KD0toECkVDsOMN/Gg2Ue/r2o+MsGx1/B9WMF0g6+zWlnrYfYZXWetl0DwATK5lZTa/21THdMrbuPX0fijGXTywvURDpCd3wIdfx9n7jPO2Gp2rcxPL/WkcIpzI211g4hEiheS+AlVyW39+C4i4MKaNK8YC+/5DRl/YHrFc7n3SZPDh+RMs6r3DS41RyRhQhz8DE0Pg4zfe/WUX4+h72TijCZ1zduh146rofwku/IGtCz5cuel+7cmTPk9ZyENYnH0ZMftkZjor9J/KamcMsN4zfaQBNJuIM3Kg8HVts3ymNIWrJ1LUn41MNt1eBDDvOWxZaHrjLyATRCFYvMr4RE01pqYKnWZ9RFfzVaYjD0QQWPWAXcCtkcAHSR6T0NxAqjLmHBNm+yWYIKG+bK2CvPNYTTNN8n4UvY1SrBpJEnLcRRns3U8nM7SVZ4GMaYzOTWtN1n0zamsl42wV0L/wqpz1SePkRZ34jca3V07XRLQSN2wjj8DyvOZUFR0="
before_install:
- sudo apt-get install -y hscolour
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
install:
- cabal --version
- travis_retry cabal update
- cabal sandbox init
- cabal install alex happy
- export PATH="$(pwd)/.cabal-sandbox/bin:$PATH"
- cabal install gtk2hs-buildtools
- cabal install --only-dependencies --enable-tests -j
script:
- cabal configure --enable-tests -v2
- cabal build
- cabal test
- cabal check
- cabal sdist
# check that the generated source-distribution can be built & installed
- export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;
cd dist/;
cabal sandbox init;
if [ -f "$SRC_TGZ" ]; then
cabal install alex happy;
export PATH="$(pwd)/.cabal-sandbox/bin:$PATH";
cabal install gtk2hs-buildtools;
cabal install "$SRC_TGZ" --enable-tests;
else
echo "expected '$SRC_TGZ' not found";
exit 1;
fi;
cd ..
- sed -i -e '/hsfm,/d' hsfm.cabal
- cabal haddock --executables --internal --hyperlink-source --html-location=https://hackage.haskell.org/package/\$pkg-\$version/docs/
after_script:
- ./update-gh-pages.sh
notifications:
email:
- hasufell@posteo.de

1
3rdparty/hpath vendored Submodule

@ -0,0 +1 @@
Subproject commit 1263fac7ec0d859550bc8145ce63872f15aaebeb

1
3rdparty/simple-sendfile vendored Submodule

@ -0,0 +1 @@
Subproject commit 869c69d3365b61831243989b81f26a2364f24f61

15
README.md
View File

@ -1,8 +1,7 @@
HSFM HSFM
==== ====
[![Join the chat at https://gitter.im/hasufell/hsfm](https://badges.gitter.im/hasufell/hsfm.svg)](https://gitter.im/hasufell/hsfm?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) __NOTE: This project is in a highly experimental state! Don't complain if it deletes your whole home directory. You should use a chroot, docker environment or similar for testing.__
[![Build Status](https://api.travis-ci.org/hasufell/hsfm.png?branch=master)](https://travis-ci.org/hasufell/hsfm)
A Gtk+:3 filemanager written in Haskell. A Gtk+:3 filemanager written in Haskell.
@ -16,13 +15,21 @@ Design goals:
Screenshots Screenshots
----------- -----------
![hsfm](https://cloud.githubusercontent.com/assets/1241845/20034565/6c3ae80e-a3c2-11e6-882c-9fe0ff202045.png "hsfm-gtk") ![hsfm](https://cloud.githubusercontent.com/assets/1241845/14768900/06efd43c-0a4d-11e6-939e-6b067bdb47ce.png "hsfm-gtk")
Installation Installation
------------ ------------
``` ```
./install.sh git submodule update --init --recursive
cabal sandbox init
cabal sandbox add-source 3rdparty/hpath
cabal sandbox add-source 3rdparty/hpath/3rdparty/posix-paths
cabal sandbox add-source 3rdparty/simple-sendfile
cabal install alex happy
export PATH="$(pwd)/.cabal-sandbox/bin:$PATH"
cabal install gtk2hs-buildtools
cabal install
``` ```

10
cabal.project
View File

@ -1,10 +0,0 @@
with-compiler: ghc-8.6.5
packages: .
optimization: 2
package *
optimization: 2
index-state: 2020-01-24T20:23:40Z

80
cabal.project.freeze
View File

@ -1,80 +0,0 @@
constraints: any.Cabal ==2.4.0.1,
any.IfElse ==0.85,
any.abstract-deque ==0.3,
abstract-deque -usecas,
any.alex ==3.2.5,
alex +small_base,
any.array ==0.5.3.0,
any.atomic-primops ==0.8.3,
atomic-primops -debug,
any.base ==4.12.0.0,
any.base-orphans ==0.8.1,
any.binary ==0.8.6.0,
any.bytestring ==0.10.8.2,
any.cairo ==0.13.8.0,
cairo +cairo_pdf +cairo_ps +cairo_svg,
any.containers ==0.6.0.1,
any.deepseq ==1.4.4.0,
any.directory ==1.3.3.0,
any.exceptions ==0.10.4,
exceptions +transformers-0-4,
any.filepath ==1.4.2.1,
any.ghc-boot-th ==8.6.5,
any.ghc-prim ==0.5.3,
any.gio ==0.13.8.0,
any.glib ==0.13.8.0,
glib +closure_signals,
any.gtk2hs-buildtools ==0.13.8.0,
gtk2hs-buildtools +closuresignals,
any.gtk3 ==0.15.4,
gtk3 -build-demos +fmode-binary +have-gio,
any.happy ==1.19.12,
happy +small_base,
any.hashable ==1.3.0.0,
hashable -examples +integer-gmp +sse2 -sse41,
any.hashtables ==1.2.3.4,
hashtables -bounds-checking -debug -detailed-profiling -portable -sse42 +unsafe-tricks,
any.heaps ==0.3.6.1,
any.hinotify-bytestring ==0.3.8.1,
any.hpath ==0.11.0,
any.hpath-filepath ==0.10.3,
any.hpath-io ==0.12.0,
any.hsc2hs ==0.68.6,
hsc2hs -in-ghc-tree,
any.integer-gmp ==1.0.2.0,
any.lockfree-queue ==0.2.3.1,
any.monad-control ==1.0.2.3,
any.monad-loops ==0.4.3,
monad-loops +base4,
any.mtl ==2.2.2,
any.network ==3.1.1.1,
any.old-locale ==1.0.0.7,
any.pango ==0.13.8.0,
pango +new-exception,
any.parsec ==3.1.13.0,
any.pretty ==1.1.3.6,
any.primitive ==0.7.0.0,
any.process ==1.6.5.0,
any.random ==1.1,
any.rts ==1.0,
any.safe ==0.3.18,
any.safe-exceptions ==0.1.7.0,
any.simple-sendfile ==0.2.30,
simple-sendfile +allow-bsd,
any.stm ==2.5.0.0,
any.streamly ==0.7.0,
streamly -benchmark -debug -dev -examples -examples-sdl -has-llvm -inspection -no-charts -no-fusion -streamk,
any.template-haskell ==2.14.0.0,
any.text ==1.2.3.1,
any.time ==1.8.0.2,
any.transformers ==0.5.6.2,
any.transformers-base ==0.4.5.2,
transformers-base +orphaninstances,
any.transformers-compat ==0.6.5,
transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
any.unix ==2.7.2.2,
any.unix-bytestring ==0.3.7.3,
any.utf8-string ==1.0.1.1,
any.vector ==0.12.0.3,
vector +boundschecks -internalchecks -unsafechecks -wall,
any.word8 ==0.1.3

287
data/Gtk/builder.xml
View File

@ -1,5 +1,5 @@
<?xml version="1.0" encoding="UTF-8"?> <?xml version="1.0" encoding="UTF-8"?>
<!-- Generated with glade 3.20.0 --> <!-- Generated with glade 3.18.3 -->
<interface> <interface>
<requires lib="gtk+" version="3.16"/> <requires lib="gtk+" version="3.16"/>
<object class="GtkGrid" id="fpropGrid"> <object class="GtkGrid" id="fpropGrid">
@ -361,123 +361,38 @@
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkBox"> <object class="GtkNotebook" id="notebook">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">True</property>
<child> <child>
<object class="GtkPaned"> <placeholder/>
<property name="visible">True</property> </child>
<property name="can_focus">True</property> <child type="tab">
<child> <placeholder/>
<object class="GtkNotebook" id="notebook1"> </child>
<property name="visible">True</property> <child>
<property name="can_focus">True</property> <placeholder/>
<property name="scrollable">True</property> </child>
<child> <child type="tab">
<placeholder/> <placeholder/>
</child> </child>
<child type="tab"> <child>
<placeholder/> <placeholder/>
</child> </child>
<child> <child type="tab">
<placeholder/> <placeholder/>
</child>
<child type="tab">
<placeholder/>
</child>
<child>
<placeholder/>
</child>
<child type="tab">
<placeholder/>
</child>
</object>
<packing>
<property name="resize">True</property>
<property name="shrink">True</property>
</packing>
</child>
<child>
<object class="GtkNotebook" id="notebook2">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="scrollable">True</property>
<child>
<placeholder/>
</child>
<child type="tab">
<placeholder/>
</child>
<child>
<placeholder/>
</child>
<child type="tab">
<placeholder/>
</child>
<child>
<placeholder/>
</child>
<child type="tab">
<placeholder/>
</child>
</object>
<packing>
<property name="resize">True</property>
<property name="shrink">True</property>
</packing>
</child>
</object>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">2</property>
</packing>
</child> </child>
</object> </object>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">1</property> <property name="position">2</property>
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkBox" id="box3"> <object class="GtkBox" id="box3">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child>
<object class="GtkToggleButton" id="leftNbBtn">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">5</property>
<property name="margin_bottom">5</property>
<property name="relief">none</property>
<property name="always_show_image">True</property>
<child>
<placeholder/>
</child>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">0</property>
</packing>
</child>
<child>
<object class="GtkSeparator">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="margin_left">2</property>
<property name="margin_right">2</property>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">1</property>
</packing>
</child>
<child> <child>
<object class="GtkStatusbar" id="statusBar"> <object class="GtkStatusbar" id="statusBar">
<property name="visible">True</property> <property name="visible">True</property>
@ -494,7 +409,7 @@
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">2</property> <property name="position">0</property>
</packing> </packing>
</child> </child>
<child> <child>
@ -511,48 +426,14 @@
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">3</property> <property name="position">1</property>
</packing>
</child>
<child>
<object class="GtkSeparator">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="margin_left">2</property>
<property name="margin_right">2</property>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">4</property>
</packing>
</child>
<child>
<object class="GtkToggleButton" id="rightNbBtn">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">5</property>
<property name="margin_bottom">5</property>
<property name="relief">none</property>
<property name="always_show_image">True</property>
<child>
<placeholder/>
</child>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">5</property>
</packing> </packing>
</child> </child>
</object> </object>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">2</property> <property name="position">3</property>
</packing> </packing>
</child> </child>
</object> </object>
@ -578,16 +459,6 @@
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="stock">gtk-zoom-fit</property> <property name="stock">gtk-zoom-fit</property>
</object> </object>
<object class="GtkImage" id="image8">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-add</property>
</object>
<object class="GtkImage" id="image9">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="icon_name">utilities-terminal</property>
</object>
<object class="GtkMenu" id="rcMenu"> <object class="GtkMenu" id="rcMenu">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
@ -638,30 +509,6 @@
<property name="use_stock">False</property> <property name="use_stock">False</property>
</object> </object>
</child> </child>
<child>
<object class="GtkSeparatorMenuItem" id="separatormenuitem4">
<property name="visible">True</property>
<property name="can_focus">False</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileNewTab">
<property name="label" translatable="yes">Tab</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="image">image8</property>
<property name="use_stock">False</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileNewTerm">
<property name="label" translatable="yes">Terminal</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="image">image9</property>
<property name="use_stock">False</property>
</object>
</child>
</object> </object>
</child> </child>
</object> </object>
@ -695,6 +542,7 @@
<property name="label">Rename</property> <property name="label">Rename</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="image">image1</property>
<property name="use_stock">False</property> <property name="use_stock">False</property>
</object> </object>
</child> </child>
@ -765,16 +613,6 @@
</object> </object>
</child> </child>
</object> </object>
<object class="GtkImage" id="leftNbIcon">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-yes</property>
</object>
<object class="GtkImage" id="rightNbIcon">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-yes</property>
</object>
<object class="GtkBox" id="viewBox"> <object class="GtkBox" id="viewBox">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
@ -784,37 +622,24 @@
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
<object class="GtkButton" id="backViewB"> <object class="GtkEntry" id="urlBar">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
<property name="receives_default">True</property> <property name="input_purpose">url</property>
<child>
<object class="GtkImage" id="imageGoBack">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-go-back</property>
</object>
</child>
</object> </object>
<packing> <packing>
<property name="expand">False</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="padding">2</property>
<property name="position">0</property> <property name="position">0</property>
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkButton" id="upViewB"> <object class="GtkButton" id="upViewB">
<property name="label">gtk-go-up</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
<property name="receives_default">True</property> <property name="receives_default">True</property>
<child> <property name="use_stock">True</property>
<object class="GtkImage" id="imageGoUp">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-go-up</property>
</object>
</child>
</object> </object>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
@ -824,37 +649,26 @@
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkButton" id="forwardViewB"> <object class="GtkButton" id="homeViewB">
<property name="label">gtk-home</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
<property name="receives_default">True</property> <property name="receives_default">True</property>
<child> <property name="use_stock">True</property>
<object class="GtkImage" id="imageGoForward">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-go-forward</property>
</object>
</child>
</object> </object>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="padding">2</property>
<property name="position">2</property> <property name="position">2</property>
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkButton" id="refreshViewB"> <object class="GtkButton" id="refreshViewB">
<property name="label">gtk-refresh</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
<property name="receives_default">True</property> <property name="receives_default">True</property>
<child> <property name="use_stock">True</property>
<object class="GtkImage" id="imageRefresh">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-refresh</property>
</object>
</child>
</object> </object>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
@ -863,37 +677,6 @@
<property name="position">3</property> <property name="position">3</property>
</packing> </packing>
</child> </child>
<child>
<object class="GtkButton" id="homeViewB">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
<child>
<object class="GtkImage" id="imageHome">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-home</property>
</object>
</child>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">4</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="urlBar">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="input_purpose">url</property>
</object>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">5</property>
</packing>
</child>
</object> </object>
<packing> <packing>
<property name="expand">False</property> <property name="expand">False</property>
@ -915,7 +698,7 @@
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
<property name="fill">True</property> <property name="fill">True</property>
<property name="position">2</property> <property name="position">1</property>
</packing> </packing>
</child> </child>
</object> </object>

29
hacking/HACKING.md
View File

@ -19,6 +19,20 @@ documentation.
## Hacking Overview ## Hacking Overview
The main data structure for the IO related File type is in
[HSFM.FileSystem.FileType](./../src/HSFM/FileSystem/FileType.hs#L93), which
should be seen as a library. This is the entry point where
[directory contents are read](./../src/HSFM/FileSystem/FileType.hs#L465)
and the File type in general [is constructed](./../src/HSFM/FileSystem/FileType.hs#L302).
The File type uses a safe Path type under the hood instead of Strings,
utilizing the [hpath](https://github.com/hasufell/hpath) library.
Note that mostly only absolute paths are allowed on type level to improve
path and thread safety.
File operations (like copy, delete etc) are defined at
[HSFM.FileSystem.FileOperation](./../src/HSFM/FileSystem/FileOperations.hs)
which use this File type.
Only a GTK GUI is currently implemented, the entry point being Only a GTK GUI is currently implemented, the entry point being
[HSFM.GUI.Gtk](./../src/HSFM/GUI/Gtk.hs). From there it flows down [HSFM.GUI.Gtk](./../src/HSFM/GUI/Gtk.hs). From there it flows down
to creating a [MyGUI object](./../src/HSFM/GUI/Gtk/Data.hs#L51) in to creating a [MyGUI object](./../src/HSFM/GUI/Gtk/Data.hs#L51) in
@ -61,8 +75,6 @@ This leads to the following benefits:
* we can reason about filepaths and rely on them to be valid (don't confuse that with "they exist") * we can reason about filepaths and rely on them to be valid (don't confuse that with "they exist")
* filepath functions like `(</>)` are now predictable and safe in contrast to the version from the `filepath` package * filepath functions like `(</>)` are now predictable and safe in contrast to the version from the `filepath` package
The [hpath](https://hackage.haskell.org/package/hpath) library does exactly that for us.
The only problem with this approach is that most libraries are still String The only problem with this approach is that most libraries are still String
based. Some provide dedicated `Foo.ByteString` modules though, but it based. Some provide dedicated `Foo.ByteString` modules though, but it
might be necessary to fork libraries. might be necessary to fork libraries.
@ -86,10 +98,17 @@ the call stack at point `b` in time, when the file information in memory
could already be out of date. There are two approaches to make this less could already be out of date. There are two approaches to make this less
sucky: sucky:
* use the hinotify library on GUI level to refresh the view (and the File representation in memory) whenever the contents of a directory changes * use the hinotify library on GUI level to refresh the view (and the File representation in memory) whenever the contents of a directory changes
* when we stuff something into the copy buffer, it is not saved as type `File a`, but as `Path Abs`... when the operation is finalized then the file at the given path is read and the copy/move/whatnot function carried out immediately * when we stuff something into the copy buffer, it is not saved as type `File a`, but as `Path Abs`... when the operation is finalized via `runFileOp`, then the file at the given path is read and the copy/move/whatnot function carried out immediately
This means we should only interact with the `HSFM.FileSystem.FileOperation`
module via the operation data types `FileOperation`, `Copy` and `Move` and
the `runFileOp` function. This doesn't completely solve the problem, but for
the rest we have to trust the posix functions to throw the proper exceptions.
In addition, we don't use the `directory` package, which is dangerous In addition, we don't use the `directory` package, which is dangerous
and broken. Instead, we use the [HPath.IO](https://hackage.haskell.org/package/hpath/docs/HPath-IO.html). and broken. Instead, we implement our own low-level wrappers around
the posix functions, so we have proper control over the internals
and know the possible exceptions.
### Exception handling ### Exception handling
@ -97,7 +116,7 @@ Exceptions are good. We don't want to wrap everything in Maybe/Either types
unless we want to handle failure immediately. Otherwise we need to make unless we want to handle failure immediately. Otherwise we need to make
sure that at least at some point IOExceptions are caught and visualized sure that at least at some point IOExceptions are caught and visualized
to the user. This is often done via e.g. `withErrorDialog` which catches to the user. This is often done via e.g. `withErrorDialog` which catches
`IOException` and [HPathIOException](https://hackage.haskell.org/package/hpath/docs/HPath-IO-Errors.html#t:HPathIOException). `IOException` and `FmIOException`.
It's also important to clean up stuff like filedescriptors via It's also important to clean up stuff like filedescriptors via
functions like `bracket` directly in our low-level code in case functions like `bracket` directly in our low-level code in case

83
hsfm.cabal
View File

@ -10,7 +10,7 @@ copyright: Copyright: (c) 2016 Julian Ospald
homepage: https://github.com/hasufell/hsfm homepage: https://github.com/hasufell/hsfm
category: Desktop category: Desktop
build-type: Simple build-type: Simple
cabal-version: >=1.22 cabal-version: >=1.10
data-files: data-files:
LICENSE LICENSE
@ -24,26 +24,31 @@ data-files:
library library
exposed-modules: exposed-modules:
HSFM.FileSystem.Errors
HSFM.FileSystem.FileOperations
HSFM.FileSystem.FileType HSFM.FileSystem.FileType
HSFM.FileSystem.UtilTypes HSFM.FileSystem.UtilTypes
HSFM.History
HSFM.Settings
HSFM.Utils.IO HSFM.Utils.IO
HSFM.Utils.MyPrelude HSFM.Utils.MyPrelude
build-depends: build-depends:
IfElse, base >= 4.7,
base >= 4.8 && < 5,
bytestring, bytestring,
containers,
data-default,
filepath >= 1.3.0.0, filepath >= 1.3.0.0,
hinotify-bytestring, hinotify-bytestring,
hpath >= 0.11.0 , hpath,
hpath-filepath >= 0.10.3, mtl >= 2.2,
hpath-io >= 0.12.0, old-locale >= 1,
posix-paths,
process,
safe, safe,
simple-sendfile,
stm, stm,
time >= 1.4.2, time >= 1.4.2,
unix, unix,
unix-bytestring,
utf8-string utf8-string
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
@ -52,14 +57,14 @@ library
FlexibleInstances FlexibleInstances
ViewPatterns ViewPatterns
ghc-options: ghc-options:
-O2
-threaded
-Wall -Wall
"-with-rtsopts=-N"
executable hsfm-gtk executable hsfm-gtk
main-is: HSFM/GUI/Gtk.hs main-is: HSFM/GUI/Gtk.hs
other-modules: other-modules:
Paths_hsfm
HSFM.FileSystem.FileType
HSFM.FileSystem.UtilTypes
HSFM.GUI.Glib.GlibString HSFM.GUI.Glib.GlibString
HSFM.GUI.Gtk.Callbacks HSFM.GUI.Gtk.Callbacks
HSFM.GUI.Gtk.Callbacks.Utils HSFM.GUI.Gtk.Callbacks.Utils
@ -69,29 +74,24 @@ executable hsfm-gtk
HSFM.GUI.Gtk.Icons HSFM.GUI.Gtk.Icons
HSFM.GUI.Gtk.MyGUI HSFM.GUI.Gtk.MyGUI
HSFM.GUI.Gtk.MyView HSFM.GUI.Gtk.MyView
HSFM.GUI.Gtk.Plugins
HSFM.GUI.Gtk.Settings
HSFM.GUI.Gtk.Utils HSFM.GUI.Gtk.Utils
HSFM.History
HSFM.Settings
HSFM.Utils.IO
HSFM.Utils.MyPrelude HSFM.Utils.MyPrelude
build-depends: build-depends:
Cabal >= 1.22.0.0, Cabal >= 1.22.0.0,
IfElse, base >= 4.7,
base >= 4.8 && < 5,
bytestring, bytestring,
containers,
data-default,
filepath >= 1.3.0.0, filepath >= 1.3.0.0,
glib >= 0.13, glib >= 0.13,
gtk3 >= 0.14.1, gtk3 >= 0.14.1,
hinotify-bytestring, hinotify-bytestring,
hpath >= 0.11.0 , hpath,
hpath-filepath >= 0.10.3,
hpath-io >= 0.12.0,
hsfm, hsfm,
monad-loops, mtl >= 2.2,
old-locale >= 1, old-locale >= 1,
posix-paths,
process, process,
safe, safe,
simple-sendfile, simple-sendfile,
@ -109,9 +109,42 @@ executable hsfm-gtk
FlexibleInstances FlexibleInstances
ViewPatterns ViewPatterns
ghc-options: ghc-options:
-O2
-threaded
-Wall -Wall
"-with-rtsopts=-N"
source-repository head
type: git
location: https://github.com/hasufell/hsfm
Test-Suite spec
Type: exitcode-stdio-1.0
Default-Language: Haskell2010
Hs-Source-Dirs: test
Main-Is: Main.hs
other-modules:
Spec
FileSystem.FileOperations.CopyDirRecursiveSpec
FileSystem.FileOperations.CopyDirRecursiveOverwriteSpec
FileSystem.FileOperations.CopyFileSpec
FileSystem.FileOperations.CopyFileOverwriteSpec
FileSystem.FileOperations.CreateDirSpec
FileSystem.FileOperations.CreateRegularFileSpec
FileSystem.FileOperations.DeleteDirRecursiveSpec
FileSystem.FileOperations.DeleteDirSpec
FileSystem.FileOperations.DeleteFileSpec
FileSystem.FileOperations.GetDirsFilesSpec
FileSystem.FileOperations.GetFileTypeSpec
FileSystem.FileOperations.MoveFileSpec
FileSystem.FileOperations.MoveFileOverwriteSpec
FileSystem.FileOperations.RecreateSymlinkSpec
FileSystem.FileOperations.RenameFileSpec
Utils
GHC-Options: -Wall
Build-Depends: base
, HUnit
, bytestring
, hpath
, hsfm
, hspec >= 1.3
, process
, unix
, utf8-string

42
install.sh
View File

@ -1,42 +0,0 @@
#!/bin/sh
set -eu
SCRIPT_DIR="$(CDPATH="" cd -- "$(dirname -- "$0")" && pwd -P)"
cd "${SCRIPT_DIR}"
# install ghcup
if ! [ -e "${SCRIPT_DIR}"/.ghcup/bin/ghcup ] ; then
mkdir -p "${SCRIPT_DIR}"/.ghcup/bin
curl --proto '=https' --tlsv1.2 -sSf https://gitlab.haskell.org/haskell/ghcup/raw/master/ghcup > "${SCRIPT_DIR}"/.ghcup/bin/ghcup
chmod +x "${SCRIPT_DIR}"/.ghcup/bin/ghcup
fi
# set up environment
export PATH="${SCRIPT_DIR}/.ghcup/bin:$PATH"
export GHCUP_INSTALL_BASE_PREFIX="${SCRIPT_DIR}"
# get ghc version from cabal.project
ghc_ver=$(grep with-compiler cabal.project | awk '{print $2}' | sed 's/ghc-//')
# install ghc
if ! ghcup list -t ghc -c installed -r | grep -q "${ghc_ver}" ; then
ghcup install "${ghc_ver}"
fi
# install cabal-install
if [ -z "$(ghcup list -t cabal-install -c installed -r)" ] ; then
ghcup install-cabal
fi
[ -e "${SCRIPT_DIR}"/bin ] || mkdir "${SCRIPT_DIR}"/bin
# install binary
cabal v2-install \
--installdir="${SCRIPT_DIR}"/bin \
--install-method=copy \
--overwrite-policy=always
echo "Binary installed in: ${SCRIPT_DIR}/bin"

339
src/HSFM/FileSystem/Errors.hs Normal file
View File

@ -0,0 +1,339 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
-- |Provides error handling.
module HSFM.FileSystem.Errors where
import Control.Exception
import Control.Monad
(
forM
, when
)
import Data.ByteString
(
ByteString
)
import Data.Data
(
Data(..)
)
import Data.Typeable
import Foreign.C.Error
(
getErrno
, Errno
)
import GHC.IO.Exception
(
IOErrorType
)
import qualified HPath as P
import HPath
(
Abs
, Path
)
import HSFM.Utils.IO
import System.IO.Error
(
catchIOError
, ioeGetErrorType
)
import qualified System.Posix.Directory.ByteString as PFD
import System.Posix.Files.ByteString
(
fileAccess
, getFileStatus
)
import qualified System.Posix.Files.ByteString as PF
data FmIOException = FileDoesNotExist ByteString
| DirDoesNotExist ByteString
| PathNotAbsolute ByteString
| FileNotExecutable ByteString
| SameFile ByteString ByteString
| NotAFile ByteString
| NotADir ByteString
| DestinationInSource ByteString ByteString
| FileDoesExist ByteString
| DirDoesExist ByteString
| IsSymlink ByteString
| InvalidOperation String
| InvalidFileName
| Can'tOpenDirectory ByteString
| CopyFailed String
| MoveFailed String
deriving (Typeable, Eq, Data)
instance Show FmIOException where
show (FileDoesNotExist fp) = "File does not exist:" ++ P.fpToString fp
show (DirDoesNotExist fp) = "Directory does not exist: "
++ P.fpToString fp
show (PathNotAbsolute fp) = "Path not absolute: " ++ P.fpToString fp
show (FileNotExecutable fp) = "File not executable: "
++ P.fpToString fp
show (SameFile fp1 fp2) = P.fpToString fp1
++ " and " ++ P.fpToString fp2
++ " are the same file!"
show (NotAFile fp) = "Not a file: " ++ P.fpToString fp
show (NotADir fp) = "Not a directory: " ++ P.fpToString fp
show (DestinationInSource fp1 fp2) = P.fpToString fp1
++ " is contained in "
++ P.fpToString fp2
show (FileDoesExist fp) = "File does exist: " ++ P.fpToString fp
show (DirDoesExist fp) = "Directory does exist: " ++ P.fpToString fp
show (IsSymlink fp) = "Is a symlink: " ++ P.fpToString fp
show (InvalidOperation str) = "Invalid operation: " ++ str
show InvalidFileName = "Invalid file name!"
show (Can'tOpenDirectory fp) = "Can't open directory: "
++ P.fpToString fp
show (CopyFailed str) = "Copying failed: " ++ str
show (MoveFailed str) = "Moving failed: " ++ str
instance Exception FmIOException
isDestinationInSource :: FmIOException -> Bool
isDestinationInSource (DestinationInSource _ _) = True
isDestinationInSource _ = False
isSameFile :: FmIOException -> Bool
isSameFile (SameFile _ _) = True
isSameFile _ = False
isFileDoesExist :: FmIOException -> Bool
isFileDoesExist (FileDoesExist _) = True
isFileDoesExist _ = False
isDirDoesExist :: FmIOException -> Bool
isDirDoesExist (DirDoesExist _) = True
isDirDoesExist _ = False
----------------------------
--[ Path based functions ]--
----------------------------
throwFileDoesExist :: Path Abs -> IO ()
throwFileDoesExist fp =
whenM (doesFileExist fp) (throw . FileDoesExist
. P.fromAbs $ fp)
throwDirDoesExist :: Path Abs -> IO ()
throwDirDoesExist fp =
whenM (doesDirectoryExist fp) (throw . DirDoesExist
. P.fromAbs $ fp)
throwFileDoesNotExist :: Path Abs -> IO ()
throwFileDoesNotExist fp =
unlessM (doesFileExist fp) (throw . FileDoesNotExist
. P.fromAbs $ fp)
throwDirDoesNotExist :: Path Abs -> IO ()
throwDirDoesNotExist fp =
unlessM (doesDirectoryExist fp) (throw . DirDoesNotExist
. P.fromAbs $ fp)
-- |Uses `isSameFile` and throws `SameFile` if it returns True.
throwSameFile :: Path Abs
-> Path Abs
-> IO ()
throwSameFile fp1 fp2 =
whenM (sameFile fp1 fp2)
(throw $ SameFile (P.fromAbs fp1) (P.fromAbs fp2))
-- |Check if the files are the same by examining device and file id.
-- This follows symbolic links.
sameFile :: Path Abs -> Path Abs -> IO Bool
sameFile fp1 fp2 =
P.withAbsPath fp1 $ \fp1' -> P.withAbsPath fp2 $ \fp2' ->
handleIOError (\_ -> return False) $ do
fs1 <- getFileStatus fp1'
fs2 <- getFileStatus fp2'
if ((PF.deviceID fs1, PF.fileID fs1) ==
(PF.deviceID fs2, PF.fileID fs2))
then return True
else return False
-- |Checks whether the destination directory is contained
-- within the source directory by comparing the device+file ID of the
-- source directory with all device+file IDs of the parent directories
-- of the destination.
throwDestinationInSource :: Path Abs -- ^ source dir
-> Path Abs -- ^ full destination, `dirname dest`
-- must exist
-> IO ()
throwDestinationInSource source dest = do
dest' <- (\x -> maybe x (\y -> x P.</> y) $ P.basename dest)
<$> (P.canonicalizePath $ P.dirname dest)
dids <- forM (P.getAllParents dest') $ \p -> do
fs <- PF.getSymbolicLinkStatus (P.fromAbs p)
return (PF.deviceID fs, PF.fileID fs)
sid <- fmap (\x -> (PF.deviceID x, PF.fileID x))
$ PF.getFileStatus (P.fromAbs source)
when (elem sid dids)
(throw $ DestinationInSource (P.fromAbs dest)
(P.fromAbs source))
-- |Checks if the given file exists and is not a directory.
-- Does not follow symlinks.
doesFileExist :: Path Abs -> IO Bool
doesFileExist fp =
handleIOError (\_ -> return False) $ do
fs <- PF.getSymbolicLinkStatus (P.fromAbs fp)
return $ not . PF.isDirectory $ fs
-- |Checks if the given file exists and is a directory.
-- Does not follow symlinks.
doesDirectoryExist :: Path Abs -> IO Bool
doesDirectoryExist fp =
handleIOError (\_ -> return False) $ do
fs <- PF.getSymbolicLinkStatus (P.fromAbs fp)
return $ PF.isDirectory fs
-- |Checks whether a file or folder is writable.
isWritable :: Path Abs -> IO Bool
isWritable fp =
handleIOError (\_ -> return False) $
fileAccess (P.fromAbs fp) False True False
-- |Checks whether the directory at the given path exists and can be
-- opened. This invokes `openDirStream` which follows symlinks.
canOpenDirectory :: Path Abs -> IO Bool
canOpenDirectory fp =
handleIOError (\_ -> return False) $ do
bracket (PFD.openDirStream . P.fromAbs $ fp)
PFD.closeDirStream
(\_ -> return ())
return True
-- |Throws a `Can'tOpenDirectory` FmIOException if the directory at the given
-- path cannot be opened.
throwCantOpenDirectory :: Path Abs -> IO ()
throwCantOpenDirectory fp =
unlessM (canOpenDirectory fp)
(throw . Can'tOpenDirectory . P.fromAbs $ fp)
--------------------------------
--[ Error handling functions ]--
--------------------------------
-- |Carries out an action, then checks if there is an IOException and
-- a specific errno. If so, then it carries out another action, otherwise
-- it rethrows the error.
catchErrno :: [Errno] -- ^ errno to catch
-> IO a -- ^ action to try, which can raise an IOException
-> IO a -- ^ action to carry out in case of an IOException and
-- if errno matches
-> IO a
catchErrno en a1 a2 =
catchIOError a1 $ \e -> do
errno <- getErrno
if errno `elem` en
then a2
else ioError e
-- |Execute the given action and retrow IO exceptions as a new Exception
-- that have the given errno. If errno does not match the exception is rethrown
-- as is.
rethrowErrnoAs :: Exception e
=> [Errno] -- ^ errno to catch
-> e -- ^ rethrow as if errno matches
-> IO a -- ^ action to try
-> IO a
rethrowErrnoAs en fmex action = catchErrno en action (throw fmex)
-- |Like `catchIOError`, with arguments swapped.
handleIOError :: (IOError -> IO a) -> IO a -> IO a
handleIOError = flip catchIOError
-- |Like `bracket`, but allows to have different clean-up
-- actions depending on whether the in-between computation
-- has raised an exception or not.
bracketeer :: IO a -- ^ computation to run first
-> (a -> IO b) -- ^ computation to run last, when
-- no exception was raised
-> (a -> IO b) -- ^ computation to run last,
-- when an exception was raised
-> (a -> IO c) -- ^ computation to run in-between
-> IO c
bracketeer before after afterEx thing =
mask $ \restore -> do
a <- before
r <- restore (thing a) `onException` afterEx a
_ <- after a
return r
reactOnError :: IO a
-> [(IOErrorType, IO a)] -- ^ reaction on IO errors
-> [(FmIOException, IO a)] -- ^ reaction on FmIOException
-> IO a
reactOnError a ios fmios =
a `catches` [iohandler, fmiohandler]
where
iohandler = Handler $
\(ex :: IOException) ->
foldr (\(t, a') y -> if ioeGetErrorType ex == t
then a'
else y)
(throwIO ex)
ios
fmiohandler = Handler $
\(ex :: FmIOException) ->
foldr (\(t, a') y -> if toConstr ex == toConstr t
then a'
else y)
(throwIO ex)
fmios

799
src/HSFM/FileSystem/FileOperations.hs Normal file
View File

@ -0,0 +1,799 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
-- |This module provides high-level IO related file operations like
-- copy, delete, move and so on. It only operates on `Path Abs` which
-- guarantees us well-typed paths which are absolute.
--
-- Some functions are just path-safe wrappers around
-- unix functions, others have stricter exception handling
-- and some implement functionality that doesn't have a unix
-- counterpart (like `copyDirRecursive`).
--
-- Some of these operations are due to their nature not _atomic_, which
-- means they may do multiple syscalls which form one context. Some
-- of them also have to examine the filetypes explicitly before the
-- syscalls, so a reasonable decision can be made. That means
-- the result is undefined if another process changes that context
-- while the non-atomic operation is still happening. However, where
-- possible, as few syscalls as possible are used and the underlying
-- exception handling is kept.
module HSFM.FileSystem.FileOperations where
import Control.Exception
(
bracket
, bracketOnError
, throw
)
import Control.Monad
(
void
, when
)
import Data.ByteString
(
ByteString
)
import Data.Foldable
(
for_
)
import Data.Maybe
(
catMaybes
)
import Data.Word
(
Word8
)
import Foreign.C.Error
(
eEXIST
, eINVAL
, eNOSYS
, eNOTEMPTY
, eXDEV
)
import Foreign.C.Types
(
CSize
)
import Foreign.Marshal.Alloc
(
allocaBytes
)
import Foreign.Ptr
(
Ptr
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import HPath
(
Path
, Abs
, Fn
)
import qualified HPath as P
import HSFM.FileSystem.Errors
import HSFM.Utils.IO
import Prelude hiding (readFile)
import System.IO.Error
(
catchIOError
, ioeGetErrorType
)
import System.Posix.ByteString
(
exclusive
)
import System.Posix.Directory.ByteString
(
createDirectory
, removeDirectory
)
import System.Posix.Directory.Traversals
(
getDirectoryContents'
)
import System.Posix.Files.ByteString
(
createSymbolicLink
, fileMode
, getFdStatus
, groupExecuteMode
, groupReadMode
, groupWriteMode
, otherExecuteMode
, otherReadMode
, otherWriteMode
, ownerModes
, ownerReadMode
, ownerWriteMode
, readSymbolicLink
, removeLink
, rename
, setFileMode
, unionFileModes
)
import qualified System.Posix.Files.ByteString as PF
import qualified "unix" System.Posix.IO.ByteString as SPI
import qualified "unix-bytestring" System.Posix.IO.ByteString as SPB
import qualified System.Posix.Directory.Traversals as SPDT
import qualified System.Posix.Directory.Foreign as SPDF
import System.Posix.IO.Sendfile.ByteString
(
sendfileFd
, FileRange(EntireFile)
)
import qualified System.Posix.Process.ByteString as SPP
import System.Posix.Types
(
FileMode
, ProcessID
, Fd
)
-- TODO: make sure we do the right thing for BlockDev, CharDev etc...
-- most operations are not implemented for these
data FileType = Directory
| RegularFile
| SymbolicLink
| BlockDevice
| CharacterDevice
| NamedPipe
| Socket
deriving (Eq, Show)
--------------------
--[ File Copying ]--
--------------------
-- |Copies a directory recursively to the given destination.
-- Does not follow symbolic links.
--
-- Safety/reliability concerns:
--
-- * not atomic
-- * examines filetypes explicitly
-- * an explicit check `throwDestinationInSource` is carried out for the
-- top directory for basic sanity, because otherwise we might end up
-- with an infinite copy loop... however, this operation is not
-- carried out recursively (because it's slow)
--
-- Throws:
--
-- - `NoSuchThing` if source directory does not exist
-- - `PermissionDenied` if output directory is not writable
-- - `PermissionDenied` if source directory can't be opened
-- - `InvalidArgument` if source directory is wrong type (symlink)
-- - `InvalidArgument` if source directory is wrong type (regular file)
-- - `SameFile` if source and destination are the same file (`FmIOException`)
-- - `AlreadyExists` if destination already exists
-- - `DestinationInSource` if destination is contained in source (`FmIOException`)
copyDirRecursive :: Path Abs -- ^ source dir
-> Path Abs -- ^ full destination
-> IO ()
copyDirRecursive fromp destdirp
= do
-- for performance, sanity checks are only done for the top dir
throwSameFile fromp destdirp
throwDestinationInSource fromp destdirp
go fromp destdirp
where
go :: Path Abs -> Path Abs -> IO ()
go fromp' destdirp' = do
-- order is important here, so we don't get empty directories
-- on failure
contents <- getDirsFiles fromp'
fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus (P.fromAbs fromp')
createDirectory (P.fromAbs destdirp') fmode'
for_ contents $ \f -> do
ftype <- getFileType f
newdest <- (destdirp' P.</>) <$> P.basename f
case ftype of
SymbolicLink -> recreateSymlink f newdest
Directory -> go f newdest
RegularFile -> copyFile f newdest
_ -> ioError $ userError $ "No idea what to do with the" ++
"given filetype: " ++ show ftype
-- |Like `copyDirRecursive` except it overwrites contents of directories
-- if any.
--
-- Throws:
--
-- - `NoSuchThing` if source directory does not exist
-- - `PermissionDenied` if output directory is not writable
-- - `PermissionDenied` if source directory can't be opened
-- - `InvalidArgument` if source directory is wrong type (symlink)
-- - `InvalidArgument` if source directory is wrong type (regular file)
-- - `SameFile` if source and destination are the same file (`FmIOException`)
-- - `DestinationInSource` if destination is contained in source (`FmIOException`)
copyDirRecursiveOverwrite :: Path Abs -- ^ source dir
-> Path Abs -- ^ full destination
-> IO ()
copyDirRecursiveOverwrite fromp destdirp
= do
-- for performance, sanity checks are only done for the top dir
throwSameFile fromp destdirp
throwDestinationInSource fromp destdirp
go fromp destdirp
where
go :: Path Abs -> Path Abs -> IO ()
go fromp' destdirp' = do
-- order is important here, so we don't get empty directories
-- on failure
contents <- getDirsFiles fromp'
fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus (P.fromAbs fromp')
catchIOError (createDirectory (P.fromAbs destdirp') fmode') $ \e ->
case ioeGetErrorType e of
AlreadyExists -> setFileMode (P.fromAbs destdirp') fmode'
_ -> ioError e
for_ contents $ \f -> do
ftype <- getFileType f
newdest <- (destdirp' P.</>) <$> P.basename f
case ftype of
SymbolicLink -> whenM (doesFileExist newdest) (deleteFile newdest)
>> recreateSymlink f newdest
Directory -> go f newdest
RegularFile -> copyFileOverwrite f newdest
_ -> ioError $ userError $ "No idea what to do with the" ++
"given filetype: " ++ show ftype
-- |Recreate a symlink.
--
-- Throws:
--
-- - `InvalidArgument` if symlink file is wrong type (file)
-- - `InvalidArgument` if symlink file is wrong type (directory)
-- - `PermissionDenied` if output directory cannot be written to
-- - `PermissionDenied` if source directory cannot be opened
-- - `AlreadyExists` if destination file already exists
-- - `SameFile` if source and destination are the same file (`FmIOException`)
--
-- Note: calls `symlink`
recreateSymlink :: Path Abs -- ^ the old symlink file
-> Path Abs -- ^ destination file
-> IO ()
recreateSymlink symsource newsym
= do
throwSameFile symsource newsym
sympoint <- readSymbolicLink (P.fromAbs symsource)
createSymbolicLink sympoint (P.fromAbs newsym)
-- |Copies the given regular file to the given destination.
-- Neither follows symbolic links, nor accepts them.
-- For "copying" symbolic links, use `recreateSymlink` instead.
--
-- Throws:
--
-- - `NoSuchThing` if source file does not exist
-- - `PermissionDenied` if output directory is not writable
-- - `PermissionDenied` if source directory can't be opened
-- - `InvalidArgument` if source file is wrong type (symlink)
-- - `InvalidArgument` if source file is wrong type (directory)
-- - `SameFile` if source and destination are the same file (`FmIOException`)
-- - `AlreadyExists` if destination already exists
--
-- Note: calls `sendfile`
copyFile :: Path Abs -- ^ source file
-> Path Abs -- ^ destination file
-> IO ()
copyFile from to = do
throwSameFile from to
_copyFile [SPDF.oNofollow]
[SPDF.oNofollow, SPDF.oExcl]
from to
-- |Like `copyFile` except it overwrites the destination if it already
-- exists.
-- This also works if source and destination are the same file.
--
-- Safety/reliability concerns:
--
-- * not atomic
-- * falls back to delete-copy method with explicit checks
--
-- Throws:
--
-- - `NoSuchThing` if source file does not exist
-- - `PermissionDenied` if output directory is not writable
-- - `PermissionDenied` if source directory can't be opened
-- - `InvalidArgument` if source file is wrong type (symlink)
-- - `InvalidArgument` if source file is wrong type (directory)
-- - `SameFile` if source and destination are the same file (`FmIOException`)
--
-- Note: calls `sendfile`
copyFileOverwrite :: Path Abs -- ^ source file
-> Path Abs -- ^ destination file
-> IO ()
copyFileOverwrite from to = do
throwSameFile from to
catchIOError (_copyFile [SPDF.oNofollow]
[SPDF.oNofollow, SPDF.oTrunc]
from to) $ \e ->
case ioeGetErrorType e of
-- if the destination file is not writable, we need to
-- figure out if we can still copy by deleting it first
PermissionDenied -> do
exists <- doesFileExist to
writable <- isWritable (P.dirname to)
if exists && writable
then deleteFile to >> copyFile from to
else ioError e
_ -> ioError e
_copyFile :: [SPDF.Flags]
-> [SPDF.Flags]
-> Path Abs -- ^ source file
-> Path Abs -- ^ destination file
-> IO ()
_copyFile sflags dflags from to
=
-- from sendfile(2) manpage:
-- Applications may wish to fall back to read(2)/write(2) in the case
-- where sendfile() fails with EINVAL or ENOSYS.
P.withAbsPath to $ \to' -> P.withAbsPath from $ \from' ->
catchErrno [eINVAL, eNOSYS]
(sendFileCopy from' to')
(void $ fallbackCopy from' to')
where
-- this is low-level stuff utilizing sendfile(2) for speed
sendFileCopy source dest =
bracket (SPDT.openFd source SPI.ReadOnly sflags Nothing)
SPI.closeFd
$ \sfd -> do
fileM <- System.Posix.Files.ByteString.fileMode
<$> getFdStatus sfd
bracketeer (SPDT.openFd dest SPI.WriteOnly
dflags $ Just fileM)
SPI.closeFd
(\fd -> SPI.closeFd fd >> deleteFile to)
$ \dfd -> sendfileFd dfd sfd EntireFile
-- low-level copy operation utilizing read(2)/write(2)
-- in case `sendFileCopy` fails/is unsupported
fallbackCopy source dest =
bracket (SPDT.openFd source SPI.ReadOnly sflags Nothing)
SPI.closeFd
$ \sfd -> do
fileM <- System.Posix.Files.ByteString.fileMode
<$> getFdStatus sfd
bracketeer (SPDT.openFd dest SPI.WriteOnly
dflags $ Just fileM)
SPI.closeFd
(\fd -> SPI.closeFd fd >> deleteFile to)
$ \dfd -> allocaBytes (fromIntegral bufSize) $ \buf ->
write' sfd dfd buf 0
where
bufSize :: CSize
bufSize = 8192
write' :: Fd -> Fd -> Ptr Word8 -> Int -> IO Int
write' sfd dfd buf totalsize = do
size <- SPB.fdReadBuf sfd buf bufSize
if size == 0
then return $ fromIntegral totalsize
else do rsize <- SPB.fdWriteBuf dfd buf size
-- TODO: switch to IOError?
when (rsize /= size) (throw . CopyFailed $ "wrong size!")
write' sfd dfd buf (totalsize + fromIntegral size)
-- |Copies anything. In case of a symlink,
-- it is just recreated, even if it points to a directory.
--
-- Safety/reliability concerns:
--
-- * examines filetypes explicitly
-- * calls `copyDirRecursive` for directories
easyCopy :: Path Abs
-> Path Abs
-> IO ()
easyCopy from to = do
ftype <- getFileType from
case ftype of
SymbolicLink -> recreateSymlink from to
RegularFile -> copyFile from to
Directory -> copyDirRecursive from to
_ -> ioError $ userError $ "No idea what to do with the" ++
"given filetype: " ++ show ftype
-- |Like `easyCopy` except it overwrites the destination if it already exists.
-- For directories, this overwrites contents without pruning them, so the resulting
-- directory may have more files than have been copied.
easyCopyOverwrite :: Path Abs
-> Path Abs
-> IO ()
easyCopyOverwrite from to = do
ftype <- getFileType from
case ftype of
SymbolicLink -> whenM (doesFileExist to) (deleteFile to)
>> recreateSymlink from to
RegularFile -> copyFileOverwrite from to
Directory -> copyDirRecursiveOverwrite from to
_ -> ioError $ userError $ "No idea what to do with the" ++
"given filetype: " ++ show ftype
---------------------
--[ File Deletion ]--
---------------------
-- |Deletes the given file, does not follow symlinks. Raises `eISDIR`
-- if run on a directory. Does not follow symbolic links.
--
-- Throws:
--
-- - `InappropriateType` for wrong file type (directory)
-- - `NoSuchThing` if the file does not exist
-- - `PermissionDenied` if the directory cannot be read
deleteFile :: Path Abs -> IO ()
deleteFile p = P.withAbsPath p removeLink
-- |Deletes the given directory, which must be empty, never symlinks.
--
-- Throws:
--
-- - `InappropriateType` for wrong file type (symlink to directory)
-- - `InappropriateType` for wrong file type (regular file)
-- - `NoSuchThing` if directory does not exist
-- - `UnsatisfiedConstraints` if directory is not empty
-- - `PermissionDenied` if we can't open or write to parent directory
--
-- Notes: calls `rmdir`
deleteDir :: Path Abs -> IO ()
deleteDir p = P.withAbsPath p removeDirectory
-- |Deletes the given directory recursively. Does not follow symbolic
-- links. Tries `deleteDir` first before attemtping a recursive
-- deletion.
--
-- Safety/reliability concerns:
--
-- * not atomic
-- * examines filetypes explicitly
--
-- Throws:
--
-- - `InappropriateType` for wrong file type (symlink to directory)
-- - `InappropriateType` for wrong file type (regular file)
-- - `NoSuchThing` if directory does not exist
-- - `PermissionDenied` if we can't open or write to parent directory
deleteDirRecursive :: Path Abs -> IO ()
deleteDirRecursive p =
catchErrno [eNOTEMPTY, eEXIST]
(deleteDir p)
$ do
files <- getDirsFiles p
for_ files $ \file -> do
ftype <- getFileType file
case ftype of
SymbolicLink -> deleteFile file
Directory -> deleteDirRecursive file
RegularFile -> deleteFile file
_ -> ioError $ userError $ "No idea what to do with the" ++
"given filetype: " ++ show ftype
removeDirectory . P.toFilePath $ p
-- |Deletes a file, directory or symlink, whatever it may be.
-- In case of directory, performs recursive deletion. In case of
-- a symlink, the symlink file is deleted.
--
-- Safety/reliability concerns:
--
-- * examines filetypes explicitly
-- * calls `deleteDirRecursive` for directories
easyDelete :: Path Abs -> IO ()
easyDelete p = do
ftype <- getFileType p
case ftype of
SymbolicLink -> deleteFile p
Directory -> deleteDirRecursive p
RegularFile -> deleteFile p
_ -> ioError $ userError $ "No idea what to do with the" ++
"given filetype: " ++ show ftype
--------------------
--[ File Opening ]--
--------------------
-- |Opens a file appropriately by invoking xdg-open. The file type
-- is not checked.
openFile :: Path Abs
-> IO ProcessID
openFile p =
P.withAbsPath p $ \fp ->
SPP.forkProcess $ SPP.executeFile "xdg-open" True [fp] Nothing
-- |Executes a program with the given arguments.
executeFile :: Path Abs -- ^ program
-> [ByteString] -- ^ arguments
-> IO ProcessID
executeFile fp args
= P.withAbsPath fp $ \fpb ->
SPP.forkProcess
$ SPP.executeFile fpb True args Nothing
---------------------
--[ File Creation ]--
---------------------
-- |Create an empty regular file at the given directory with the given filename.
--
-- Throws:
--
-- - `PermissionDenied` if output directory cannot be written to
-- - `AlreadyExists` if destination file already exists
createRegularFile :: Path Abs -> IO ()
createRegularFile dest =
bracket (SPI.openFd (P.fromAbs dest) SPI.WriteOnly (Just newFilePerms)
(SPI.defaultFileFlags { exclusive = True }))
SPI.closeFd
(\_ -> return ())
-- |Create an empty directory at the given directory with the given filename.
--
-- Throws:
--
-- - `PermissionDenied` if output directory cannot be written to
-- - `AlreadyExists` if destination directory already exists
createDir :: Path Abs -> IO ()
createDir dest = createDirectory (P.fromAbs dest) newDirPerms
----------------------------
--[ File Renaming/Moving ]--
----------------------------
-- |Rename a given file with the provided filename. Destination and source
-- must be on the same device, otherwise `eXDEV` will be raised.
--
-- Does not follow symbolic links, but renames the symbolic link file.
--
-- Safety/reliability concerns:
--
-- * has a separate set of exception handling, apart from the syscall
--
-- Throws:
--
-- - `NoSuchThing` if source file does not exist
-- - `PermissionDenied` if output directory cannot be written to
-- - `PermissionDenied` if source directory cannot be opened
-- - `UnsupportedOperation` if source and destination are on different devices
-- - `FileDoesExist` if destination file already exists
-- - `DirDoesExist` if destination directory already exists
-- - `SameFile` if destination and source are the same file (`FmIOException`)
--
-- Note: calls `rename` (but does not allow to rename over existing files)
renameFile :: Path Abs -> Path Abs -> IO ()
renameFile fromf tof = do
throwSameFile fromf tof
throwFileDoesExist tof
throwDirDoesExist tof
rename (P.fromAbs fromf) (P.fromAbs tof)
-- |Move a file. This also works across devices by copy-delete fallback.
-- And also works on directories.
--
-- Does not follow symbolic links, but renames the symbolic link file.
--
-- Safety/reliability concerns:
--
-- * copy-delete fallback is inherently non-atomic
--
-- Throws:
--
-- - `NoSuchThing` if source file does not exist
-- - `PermissionDenied` if output directory cannot be written to
-- - `PermissionDenied` if source directory cannot be opened
-- - `FileDoesExist` if destination file already exists
-- - `DirDoesExist` if destination directory already exists
-- - `SameFile` if destination and source are the same file (`FmIOException`)
--
-- Note: calls `rename` (but does not allow to rename over existing files)
moveFile :: Path Abs -- ^ file to move
-> Path Abs -- ^ destination
-> IO ()
moveFile from to = do
throwSameFile from to
catchErrno [eXDEV] (renameFile from to) $ do
easyCopy from to
easyDelete from
-- |Like `moveFile`, but overwrites the destination if it exists.
--
-- Does not follow symbolic links, but renames the symbolic link file.
--
-- Safety/reliability concerns:
--
-- * copy-delete fallback is inherently non-atomic
-- * checks for file types and destination file existence explicitly
--
-- Throws:
--
-- - `NoSuchThing` if source file does not exist
-- - `PermissionDenied` if output directory cannot be written to
-- - `PermissionDenied` if source directory cannot be opened
-- - `SameFile` if destination and source are the same file (`FmIOException`)
--
-- Note: calls `rename` (but does not allow to rename over existing files)
moveFileOverwrite :: Path Abs -- ^ file to move
-> Path Abs -- ^ destination
-> IO ()
moveFileOverwrite from to = do
throwSameFile from to
ft <- getFileType from
writable <- isWritable $ P.dirname to
case ft of
RegularFile -> do
exists <- doesFileExist to
when (exists && writable) (deleteFile to)
SymbolicLink -> do
exists <- doesFileExist to
when (exists && writable) (deleteFile to)
Directory -> do
exists <- doesDirectoryExist to
when (exists && writable) (deleteDir to)
_ -> ioError $ userError $ "Don't know how to handle filetype " ++
show ft
moveFile from to
-----------------------
--[ File Permissions]--
-----------------------
-- |Default permissions for a new file.
newFilePerms :: FileMode
newFilePerms
= ownerWriteMode
`unionFileModes` ownerReadMode
`unionFileModes` groupWriteMode
`unionFileModes` groupReadMode
`unionFileModes` otherWriteMode
`unionFileModes` otherReadMode
-- |Default permissions for a new directory.
newDirPerms :: FileMode
newDirPerms
= ownerModes
`unionFileModes` groupExecuteMode
`unionFileModes` groupReadMode
`unionFileModes` otherExecuteMode
`unionFileModes` otherReadMode
-------------------------
--[ Directory reading ]--
-------------------------
-- |Gets all filenames of the given directory. This excludes "." and "..".
-- This version does not follow symbolic links.
--
-- Throws:
--
-- - `NoSuchThing` if directory does not exist
-- - `InappropriateType` if file type is wrong (file)
-- - `InappropriateType` if file type is wrong (symlink to file)
-- - `InappropriateType` if file type is wrong (symlink to dir)
-- - `PermissionDenied` if directory cannot be opened
getDirsFiles :: Path Abs -- ^ dir to read
-> IO [Path Abs]
getDirsFiles p =
P.withAbsPath p $ \fp ->
bracketOnError (SPDT.openFd fp SPI.ReadOnly [SPDF.oNofollow] Nothing)
SPI.closeFd
$ \fd ->
return
. catMaybes
. fmap (\x -> (P.</>) p <$> (parseMaybe . snd $ x))
=<< getDirectoryContents' fd
where
parseMaybe :: ByteString -> Maybe (Path Fn)
parseMaybe = P.parseFn
---------------------------
--[ FileType operations ]--
---------------------------
-- |Get the file type of the file located at the given path. Does
-- not follow symbolic links.
--
-- Throws:
--
-- - `NoSuchThing` if the file does not exist
-- - `PermissionDenied` if any part of the path is not accessible
getFileType :: Path Abs -> IO FileType
getFileType p = do
fs <- PF.getSymbolicLinkStatus (P.fromAbs p)
decide fs
where
decide fs
| PF.isDirectory fs = return Directory
| PF.isRegularFile fs = return RegularFile
| PF.isSymbolicLink fs = return SymbolicLink
| PF.isBlockDevice fs = return BlockDevice
| PF.isCharacterDevice fs = return CharacterDevice
| PF.isNamedPipe fs = return NamedPipe
| PF.isSocket fs = return Socket
| otherwise = ioError $ userError "No filetype?!"

178
src/HSFM/FileSystem/FileType.hs
View File

@ -38,10 +38,7 @@ module HSFM.FileSystem.FileType where
import Data.ByteString(ByteString) import Data.ByteString(ByteString)
import Data.ByteString.UTF8 import Data.Default
(
toString
)
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
( (
POSIXTime POSIXTime
@ -54,9 +51,18 @@ import HPath
, Path , Path
) )
import qualified HPath as P import qualified HPath as P
import HPath.IO hiding (FileType(..)) import HSFM.FileSystem.Errors
import HPath.IO.Errors import HSFM.FileSystem.FileOperations
(
getDirsFiles
)
import HSFM.Utils.MyPrelude
import Prelude hiding(readFile) import Prelude hiding(readFile)
import System.IO.Error
(
ioeGetErrorType
, isDoesNotExistErrorType
)
import System.Posix.FilePath import System.Posix.FilePath
( (
(</>) (</>)
@ -91,9 +97,13 @@ import System.Posix.Types
-- |The String in the path field is always a full path. -- |The String in the path field is always a full path.
-- The free type variable is used in the File/Dir constructor and can hold -- The free type variable is used in the File/Dir constructor and can hold
-- Handles, Strings representing a file's contents or anything else you can -- Handles, Strings representing a file's contents or anything else you can
-- think of. -- think of. We catch any IO errors in the Failed constructor.
data File a = data File a =
Dir { Failed {
path :: !(Path Abs)
, err :: IOError
}
| Dir {
path :: !(Path Abs) path :: !(Path Abs)
, fvar :: a , fvar :: a
} }
@ -104,8 +114,8 @@ data File a =
| SymLink { | SymLink {
path :: !(Path Abs) path :: !(Path Abs)
, fvar :: a , fvar :: a
, sdest :: Maybe (File a) -- ^ symlink madness, , sdest :: File a -- ^ symlink madness,
-- we need to know where it points to -- we need to know where it points to
, rawdest :: !ByteString , rawdest :: !ByteString
} }
| BlockDev { | BlockDev {
@ -176,31 +186,28 @@ fileLike f = (False, f)
sdir :: File FileInfo -> (Bool, File FileInfo) sdir :: File FileInfo -> (Bool, File FileInfo)
sdir f@SymLink{ sdest = (Just s@SymLink{} )} sdir f@SymLink{ sdest = (s@SymLink{} )}
-- we have to follow a chain of symlinks here, but -- we have to follow a chain of symlinks here, but
-- return only the very first level -- return only the very first level
-- TODO: this is probably obsolete now -- TODO: this is probably obsolete now
= case sdir s of = case sdir s of
(True, _) -> (True, f) (True, _) -> (True, f)
_ -> (False, f) _ -> (False, f)
sdir f@SymLink{ sdest = Just Dir{} } sdir f@SymLink{ sdest = Dir{} }
= (True, f) = (True, f)
sdir f@Dir{} = (True, f) sdir f@Dir{} = (True, f)
sdir f = (False, f) sdir f = (False, f)
-- |Matches on any non-directory kind of files, excluding symlinks. -- |Matches on any non-directory kind of files, excluding symlinks.
pattern FileLike :: File FileInfo -> File FileInfo
pattern FileLike f <- (fileLike -> (True, f)) pattern FileLike f <- (fileLike -> (True, f))
-- |Matches a list of directories or symlinks pointing to directories. -- |Matches a list of directories or symlinks pointing to directories.
pattern DirList :: [File FileInfo] -> [File FileInfo]
pattern DirList fs <- (\fs -> (and . fmap (fst . sdir) $ fs, fs) pattern DirList fs <- (\fs -> (and . fmap (fst . sdir) $ fs, fs)
-> (True, fs)) -> (True, fs))
-- |Matches a list of any non-directory kind of files or symlinks -- |Matches a list of any non-directory kind of files or symlinks
-- pointing to such. -- pointing to such.
pattern FileLikeList :: [File FileInfo] -> [File FileInfo]
pattern FileLikeList fs <- (\fs -> (and pattern FileLikeList fs <- (\fs -> (and
. fmap (fst . sfileLike) . fmap (fst . sfileLike)
$ fs, fs) -> (True, fs)) $ fs, fs) -> (True, fs))
@ -215,33 +222,31 @@ brokenSymlink f = (isBrokenSymlink f, f)
fileLikeSym :: File FileInfo -> (Bool, File FileInfo) fileLikeSym :: File FileInfo -> (Bool, File FileInfo)
fileLikeSym f@SymLink{ sdest = Just s@SymLink{} } fileLikeSym f@SymLink{ sdest = s@SymLink{} }
= case fileLikeSym s of = case fileLikeSym s of
(True, _) -> (True, f) (True, _) -> (True, f)
_ -> (False, f) _ -> (False, f)
fileLikeSym f@SymLink{ sdest = Just RegFile{} } = (True, f) fileLikeSym f@SymLink{ sdest = RegFile{} } = (True, f)
fileLikeSym f@SymLink{ sdest = Just BlockDev{} } = (True, f) fileLikeSym f@SymLink{ sdest = BlockDev{} } = (True, f)
fileLikeSym f@SymLink{ sdest = Just CharDev{} } = (True, f) fileLikeSym f@SymLink{ sdest = CharDev{} } = (True, f)
fileLikeSym f@SymLink{ sdest = Just NamedPipe{} } = (True, f) fileLikeSym f@SymLink{ sdest = NamedPipe{} } = (True, f)
fileLikeSym f@SymLink{ sdest = Just Socket{} } = (True, f) fileLikeSym f@SymLink{ sdest = Socket{} } = (True, f)
fileLikeSym f = (False, f) fileLikeSym f = (False, f)
dirSym :: File FileInfo -> (Bool, File FileInfo) dirSym :: File FileInfo -> (Bool, File FileInfo)
dirSym f@SymLink{ sdest = Just s@SymLink{} } dirSym f@SymLink{ sdest = s@SymLink{} }
= case dirSym s of = case dirSym s of
(True, _) -> (True, f) (True, _) -> (True, f)
_ -> (False, f) _ -> (False, f)
dirSym f@SymLink{ sdest = Just Dir{} } = (True, f) dirSym f@SymLink{ sdest = Dir{} } = (True, f)
dirSym f = (False, f) dirSym f = (False, f)
-- |Matches on symlinks pointing to file-like files only. -- |Matches on symlinks pointing to file-like files only.
pattern FileLikeSym :: File FileInfo -> File FileInfo
pattern FileLikeSym f <- (fileLikeSym -> (True, f)) pattern FileLikeSym f <- (fileLikeSym -> (True, f))
-- |Matches on broken symbolic links. -- |Matches on broken symbolic links.
pattern BrokenSymlink :: File FileInfo -> File FileInfo
pattern BrokenSymlink f <- (brokenSymlink -> (True, f)) pattern BrokenSymlink f <- (brokenSymlink -> (True, f))
@ -249,11 +254,9 @@ pattern BrokenSymlink f <- (brokenSymlink -> (True, f))
-- If the symlink is pointing to a symlink pointing to a directory, then -- If the symlink is pointing to a symlink pointing to a directory, then
-- it will return True, but also return the first element in the symlink- -- it will return True, but also return the first element in the symlink-
-- chain, not the last. -- chain, not the last.
pattern DirOrSym :: File FileInfo -> File FileInfo
pattern DirOrSym f <- (sdir -> (True, f)) pattern DirOrSym f <- (sdir -> (True, f))
-- |Matches on symlinks pointing to directories only. -- |Matches on symlinks pointing to directories only.
pattern DirSym :: File FileInfo -> File FileInfo
pattern DirSym f <- (dirSym -> (True, f)) pattern DirSym f <- (dirSym -> (True, f))
-- |Matches on any non-directory kind of files or symlinks pointing to -- |Matches on any non-directory kind of files or symlinks pointing to
@ -261,7 +264,6 @@ pattern DirSym f <- (dirSym -> (True, f))
-- If the symlink is pointing to a symlink pointing to such a file, then -- If the symlink is pointing to a symlink pointing to such a file, then
-- it will return True, but also return the first element in the symlink- -- it will return True, but also return the first element in the symlink-
-- chain, not the last. -- chain, not the last.
pattern FileLikeOrSym :: File FileInfo -> File FileInfo
pattern FileLikeOrSym f <- (sfileLike -> (True, f)) pattern FileLikeOrSym f <- (sfileLike -> (True, f))
@ -300,10 +302,11 @@ instance Ord (File FileInfo) where
-- |Reads a file or directory Path into an `AnchoredFile`, filling the free -- |Reads a file or directory Path into an `AnchoredFile`, filling the free
-- variables via the given function. -- variables via the given function.
pathToFile :: (Path Abs -> IO a) readFile :: (Path Abs -> IO a)
-> Path Abs -> Path Abs
-> IO (File a) -> IO (File a)
pathToFile ff p = do readFile ff p =
handleDT p $ do
fs <- PF.getSymbolicLinkStatus (P.toFilePath p) fs <- PF.getSymbolicLinkStatus (P.toFilePath p)
fv <- ff p fv <- ff p
constructFile fs fv p constructFile fs fv p
@ -313,12 +316,11 @@ pathToFile ff p = do
-- symlink madness, we need to make sure we save the correct -- symlink madness, we need to make sure we save the correct
-- File -- File
x <- PF.readSymbolicLink (P.fromAbs p') x <- PF.readSymbolicLink (P.fromAbs p')
resolvedSyml <- handleIOError (\_ -> return Nothing) $ do resolvedSyml <- handleDT p' $ do
-- watch out, we call </> from 'filepath' here, but it is safe -- watch out, we call </> from 'filepath' here, but it is safe
let sfp = (P.fromAbs . P.dirname $ p') </> x let sfp = (P.fromAbs . P.dirname $ p') </> x
rsfp <- realpath sfp rsfp <- realpath sfp
f <- pathToFile ff =<< P.parseAbs rsfp readFile ff =<< P.parseAbs rsfp
return $ Just f
return $ SymLink p' fv resolvedSyml x return $ SymLink p' fv resolvedSyml x
| PF.isDirectory fs = return $ Dir p' fv | PF.isDirectory fs = return $ Dir p' fv
| PF.isRegularFile fs = return $ RegFile p' fv | PF.isRegularFile fs = return $ RegFile p' fv
@ -326,7 +328,8 @@ pathToFile ff p = do
| PF.isCharacterDevice fs = return $ CharDev p' fv | PF.isCharacterDevice fs = return $ CharDev p' fv
| PF.isNamedPipe fs = return $ NamedPipe p' fv | PF.isNamedPipe fs = return $ NamedPipe p' fv
| PF.isSocket fs = return $ Socket p' fv | PF.isSocket fs = return $ Socket p' fv
| otherwise = ioError $ userError "Unknown filetype!" | otherwise = return $ Failed p' (userError
"Unknown filetype!")
-- |Get the contents of a given directory and return them as a list -- |Get the contents of a given directory and return them as a list
@ -336,10 +339,11 @@ readDirectoryContents :: (Path Abs -> IO a) -- ^ fills free a variable
-> IO [File a] -> IO [File a]
readDirectoryContents ff p = do readDirectoryContents ff p = do
files <- getDirsFiles p files <- getDirsFiles p
mapM (pathToFile ff) files fcs <- mapM (readFile ff) files
return $ removeNonexistent fcs
-- |A variant of `readDirectoryContents` where the second argument -- |A variant of `readDirectoryContents` where the third argument
-- is a `File`. If a non-directory is passed returns an empty list. -- is a `File`. If a non-directory is passed returns an empty list.
getContents :: (Path Abs -> IO a) getContents :: (Path Abs -> IO a)
-> File FileInfo -> File FileInfo
@ -352,12 +356,12 @@ getContents _ _ = return []
-- |Go up one directory in the filesystem hierarchy. -- |Go up one directory in the filesystem hierarchy.
goUp :: File FileInfo -> IO (File FileInfo) goUp :: File FileInfo -> IO (File FileInfo)
goUp file = pathToFile getFileInfo (P.dirname . path $ file) goUp file = readFile getFileInfo (P.dirname . path $ file)
-- |Go up one directory in the filesystem hierarchy. -- |Go up one directory in the filesystem hierarchy.
goUp' :: Path Abs -> IO (File FileInfo) goUp' :: Path Abs -> IO (File FileInfo)
goUp' fp = pathToFile getFileInfo $ P.dirname fp goUp' fp = readFile getFileInfo $ P.dirname fp
@ -368,6 +372,28 @@ goUp' fp = pathToFile getFileInfo $ P.dirname fp
---- HANDLING FAILURES ----
-- |True if any Failed constructors in the tree.
anyFailed :: [File a] -> Bool
anyFailed = not . successful
-- |True if there are no Failed constructors in the tree.
successful :: [File a] -> Bool
successful = null . failures
-- |Returns true if argument is a `Failed` constructor.
failed :: File a -> Bool
failed (Failed _ _) = True
failed _ = False
-- |Returns a list of 'Failed' constructors only.
failures :: [File a] -> [File a]
failures = filter failed
---- ORDERING AND EQUALITY ---- ---- ORDERING AND EQUALITY ----
@ -375,7 +401,11 @@ goUp' fp = pathToFile getFileInfo $ P.dirname fp
-- HELPER: a non-recursive comparison -- HELPER: a non-recursive comparison
comparingConstr :: File FileInfo -> File FileInfo -> Ordering comparingConstr :: File FileInfo -> File FileInfo -> Ordering
comparingConstr (Failed _ _) (DirOrSym _) = LT
comparingConstr (Failed _ _) (FileLikeOrSym _) = LT
comparingConstr (FileLikeOrSym _) (Failed _ _) = GT
comparingConstr (FileLikeOrSym _) (DirOrSym _) = GT comparingConstr (FileLikeOrSym _) (DirOrSym _) = GT
comparingConstr (DirOrSym _) (Failed _ _) = GT
comparingConstr (DirOrSym _) (FileLikeOrSym _) = LT comparingConstr (DirOrSym _) (FileLikeOrSym _) = LT
-- else compare on the names of constructors that are the same, without -- else compare on the names of constructors that are the same, without
-- looking at the contents of Dir constructors: -- looking at the contents of Dir constructors:
@ -435,6 +465,8 @@ isSocketC _ = False
-- |Gets all file information. -- |Gets all file information.
getFileInfo :: Path Abs -> IO FileInfo getFileInfo :: Path Abs -> IO FileInfo
getFileInfo fp = do getFileInfo fp = do
@ -457,6 +489,29 @@ getFileInfo fp = do
---- FAILURE HELPERS: ----
-- Handles an IO exception by returning a Failed constructor filled with that
-- exception. Does not handle FmIOExceptions.
handleDT :: Path Abs
-> IO (File a)
-> IO (File a)
handleDT p
= handleIOError $ \e -> return $ Failed p e
-- DoesNotExist errors not present at the topmost level could happen if a
-- named file or directory is deleted after being listed by
-- getDirectoryContents but before we can get it into memory.
-- So we filter those errors out because the user should not see errors
-- raised by the internal implementation of this module:
-- This leaves the error if it exists in the top (user-supplied) level:
removeNonexistent :: [File a] -> [File a]
removeNonexistent = filter isOkConstructor
where
isOkConstructor c = not (failed c) || isOkError c
isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err
---- SYMLINK HELPERS: ---- ---- SYMLINK HELPERS: ----
@ -467,25 +522,45 @@ getFileInfo fp = do
-- --
-- When called on a non-symlink, returns False. -- When called on a non-symlink, returns False.
isBrokenSymlink :: File FileInfo -> Bool isBrokenSymlink :: File FileInfo -> Bool
isBrokenSymlink (SymLink _ _ Nothing _) = True isBrokenSymlink (SymLink _ _ Failed{} _) = True
isBrokenSymlink _ = False isBrokenSymlink _ = False
---- OTHER: ----
---- PACKERS: ---- -- |Apply a function on the free variable. If there is no free variable
-- for the given constructor the value from the `Default` class is used.
fromFreeVar :: (Default d) => (a -> d) -> File a -> d
fromFreeVar f df = maybeD f $ getFreeVar df
getFPasStr :: File a -> String
getFPasStr = P.fpToString . P.fromAbs . path
-- |Gets the free variable. Returns Nothing if the constructor is of `Failed`.
getFreeVar :: File a -> Maybe a
getFreeVar (Dir _ d) = Just d
getFreeVar (RegFile _ d) = Just d
getFreeVar (SymLink _ d _ _) = Just d
getFreeVar (BlockDev _ d) = Just d
getFreeVar (CharDev _ d) = Just d
getFreeVar (NamedPipe _ d) = Just d
getFreeVar (Socket _ d) = Just d
getFreeVar _ = Nothing
-- |Pack the modification time into a string. -- |Pack the modification time into a string.
packModTime :: File FileInfo packModTime :: File FileInfo
-> String -> String
packModTime = epochToString . modificationTime . fvar packModTime = fromFreeVar $ epochToString . modificationTime
-- |Pack the modification time into a string. -- |Pack the modification time into a string.
packAccessTime :: File FileInfo packAccessTime :: File FileInfo
-> String -> String
packAccessTime = epochToString . accessTime . fvar packAccessTime = fromFreeVar $ epochToString . accessTime
epochToString :: EpochTime -> String epochToString :: EpochTime -> String
@ -495,12 +570,12 @@ epochToString = show . posixSecondsToUTCTime . realToFrac
-- |Pack the permissions into a string, similar to what "ls -l" does. -- |Pack the permissions into a string, similar to what "ls -l" does.
packPermissions :: File FileInfo packPermissions :: File FileInfo
-> String -> String
packPermissions file = (pStr . fileMode) . fvar $ file packPermissions dt = fromFreeVar (pStr . fileMode) dt
where where
pStr :: FileMode -> String pStr :: FileMode -> String
pStr ffm = typeModeStr ++ ownerModeStr ++ groupModeStr ++ otherModeStr pStr ffm = typeModeStr ++ ownerModeStr ++ groupModeStr ++ otherModeStr
where where
typeModeStr = case file of typeModeStr = case dt of
Dir {} -> "d" Dir {} -> "d"
RegFile {} -> "-" RegFile {} -> "-"
SymLink {} -> "l" SymLink {} -> "l"
@ -508,6 +583,7 @@ packPermissions file = (pStr . fileMode) . fvar $ file
CharDev {} -> "c" CharDev {} -> "c"
NamedPipe {} -> "p" NamedPipe {} -> "p"
Socket {} -> "s" Socket {} -> "s"
_ -> "?"
ownerModeStr = hasFmStr PF.ownerReadMode "r" ownerModeStr = hasFmStr PF.ownerReadMode "r"
++ hasFmStr PF.ownerWriteMode "w" ++ hasFmStr PF.ownerWriteMode "w"
++ hasFmStr PF.ownerExecuteMode "x" ++ hasFmStr PF.ownerExecuteMode "x"
@ -532,6 +608,7 @@ packFileType file = case file of
CharDev {} -> "Char Device" CharDev {} -> "Char Device"
NamedPipe {} -> "Named Pipe" NamedPipe {} -> "Named Pipe"
Socket {} -> "Socket" Socket {} -> "Socket"
_ -> "Unknown"
packLinkDestination :: File a -> Maybe ByteString packLinkDestination :: File a -> Maybe ByteString
@ -539,12 +616,3 @@ packLinkDestination file = case file of
SymLink { rawdest = dest } -> Just dest SymLink { rawdest = dest } -> Just dest
_ -> Nothing _ -> Nothing
---- OTHER: ----
getFPasStr :: File a -> String
getFPasStr = toString . P.fromAbs . path

5
src/HSFM/FileSystem/UtilTypes.hs
View File

@ -16,6 +16,7 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--} --}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
@ -47,7 +48,7 @@ import HPath
( (
Path Path
, Abs , Abs
, Rel , Fn
) )
@ -79,5 +80,5 @@ data FCollisonMode = Strict -- ^ fail if the target already exists
| Overwrite | Overwrite
| OverwriteAll | OverwriteAll
| Skip | Skip
| Rename (Path Rel) | Rename (Path Fn)

3
src/HSFM/GUI/Glib/GlibString.hs
View File

@ -16,6 +16,7 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--} --}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
@ -66,7 +67,7 @@ instance GlibString BS.ByteString where
newUTFStringLen = newUTFStringLen . toString newUTFStringLen = newUTFStringLen . toString
genUTFOfs = genUTFOfs . toString genUTFOfs = genUTFOfs . toString
stringLength = BS.length stringLength = BS.length
unPrintf s = BS.intercalate (BS.pack [_percent, _percent]) (BS.split _percent s) unPrintf s = BS.intercalate "%%" (BS.split _percent s)
foreign import ccall unsafe "string.h strlen" c_strlen foreign import ccall unsafe "string.h strlen" c_strlen

26
src/HSFM/GUI/Gtk.hs
View File

@ -16,52 +16,40 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--} --}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
module Main where module Main where
import qualified Data.ByteString as BS
import Data.Maybe import Data.Maybe
( (
fromJust fromJust
, fromMaybe , fromMaybe
) )
import Data.Word8
import Graphics.UI.Gtk import Graphics.UI.Gtk
import qualified HPath as P import qualified HPath as P
import HSFM.FileSystem.FileType
import HSFM.GUI.Gtk.Callbacks import HSFM.GUI.Gtk.Callbacks
import HSFM.GUI.Gtk.Data import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.MyGUI import HSFM.GUI.Gtk.MyGUI
import HSFM.GUI.Gtk.MyView import HSFM.GUI.Gtk.MyView
import Prelude hiding(readFile)
import Safe import Safe
( (
headDef headDef
) )
import System.IO.Error
(
catchIOError
)
import qualified System.Posix.Env.ByteString as SPE import qualified System.Posix.Env.ByteString as SPE
slash :: BS.ByteString
slash = BS.singleton _slash
main :: IO () main :: IO ()
main = do main = do
args <- SPE.getArgs
let mdir = fromMaybe (fromJust $ P.parseAbs slash)
(P.parseAbs . headDef slash $ args)
file <- catchIOError (pathToFile getFileInfo mdir) $
\_ -> pathToFile getFileInfo . fromJust $ P.parseAbs slash
_ <- initGUI _ <- initGUI
args <- SPE.getArgs
let mdir = fromMaybe (fromJust $ P.parseAbs "/")
(P.parseAbs . headDef "/" $ args)
mygui <- createMyGUI mygui <- createMyGUI
_ <- newTab mygui (notebook1 mygui) createTreeView file (-1) _ <- newTab mygui createTreeView mdir
_ <- newTab mygui (notebook2 mygui) createTreeView file (-1)
setGUICallbacks mygui setGUICallbacks mygui

478
src/HSFM/GUI/Gtk/Callbacks.hs
View File

@ -16,7 +16,7 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--} --}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.Callbacks where module HSFM.GUI.Gtk.Callbacks where
@ -28,34 +28,22 @@ import Control.Concurrent.STM
) )
import Control.Exception import Control.Exception
( (
throwIO throw
) )
import Control.Monad import Control.Monad
( (
forM forM_
, forM_
, join
, void , void
, when , when
) )
import Control.Monad.IfElse
import Control.Monad.IO.Class import Control.Monad.IO.Class
( (
liftIO liftIO
) )
import Control.Monad.Loops
(
iterateUntil
)
import Data.ByteString import Data.ByteString
( (
ByteString ByteString
) )
import Data.ByteString.UTF8
(
fromString
, toString
)
import Data.Foldable import Data.Foldable
( (
for_ for_
@ -63,45 +51,35 @@ import Data.Foldable
import Graphics.UI.Gtk import Graphics.UI.Gtk
import qualified HPath as P import qualified HPath as P
import HPath import HPath
( (
fromAbs Abs
, Abs , Path
, Path )
) import HSFM.FileSystem.Errors
import HPath.IO import HSFM.FileSystem.FileOperations
import HPath.IO.Errors
import HSFM.FileSystem.FileType import HSFM.FileSystem.FileType
import HSFM.FileSystem.UtilTypes import HSFM.FileSystem.UtilTypes
import HSFM.GUI.Gtk.Callbacks.Utils import HSFM.GUI.Gtk.Callbacks.Utils
import HSFM.GUI.Gtk.Data import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Dialogs import HSFM.GUI.Gtk.Dialogs
import HSFM.GUI.Gtk.MyView import HSFM.GUI.Gtk.MyView
import HSFM.GUI.Gtk.Plugins
import HSFM.GUI.Gtk.Settings
import HSFM.GUI.Gtk.Utils import HSFM.GUI.Gtk.Utils
import HSFM.History
import HSFM.Settings
import HSFM.Utils.IO import HSFM.Utils.IO
import Prelude hiding(readFile) import Prelude hiding(readFile)
import System.Glib.UTFString import System.Glib.UTFString
( (
glibToString glibToString
) )
import System.Posix.Env.ByteString
(
getEnv
)
import qualified System.Posix.Process.ByteString as SPP import qualified System.Posix.Process.ByteString as SPP
import System.Posix.Types import System.Posix.Types
( (
ProcessID ProcessID
) )
import Control.Concurrent.MVar
(
putMVar
, readMVar
, takeMVar
)
import Paths_hsfm
(
getDataFileName
)
@ -120,18 +98,6 @@ import Paths_hsfm
setGUICallbacks :: MyGUI -> IO () setGUICallbacks :: MyGUI -> IO ()
setGUICallbacks mygui = do setGUICallbacks mygui = do
-- notebook toggle buttons
_ <- leftNbBtn mygui `on` toggled $ do
isPressed <- toggleButtonGetActive $ leftNbBtn mygui
if isPressed then widgetShow $ notebook1 mygui
else widgetHide $ notebook1 mygui
_ <- rightNbBtn mygui `on` toggled $ do
isPressed <- toggleButtonGetActive $ rightNbBtn mygui
if isPressed then widgetShow $ notebook2 mygui
else widgetHide $ notebook2 mygui
-- statusbar
_ <- clearStatusBar mygui `on` buttonActivated $ do _ <- clearStatusBar mygui `on` buttonActivated $ do
popStatusbar mygui popStatusbar mygui
writeTVarIO (operationBuffer mygui) None writeTVarIO (operationBuffer mygui) None
@ -147,8 +113,8 @@ setGUICallbacks mygui = do
-- key events -- key events
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
QuitModifier <- eventModifier [Control] <- eventModifier
QuitKey <- fmap glibToString eventKeyName "q" <- fmap glibToString eventKeyName
liftIO mainQuit liftIO mainQuit
return () return ()
@ -203,45 +169,7 @@ setViewCallbacks mygui myview = do
commonGuiEvents fmv = do commonGuiEvents fmv = do
let view = fmViewToContainer fmv let view = fmViewToContainer fmv
-- focus events
_ <- notebook1 mygui `on` setFocusChild $ \w ->
case w of
Nothing -> widgetSetSensitive (leftNbIcon mygui) False
_ -> widgetSetSensitive (leftNbIcon mygui) True
_ <- notebook2 mygui `on` setFocusChild $ \w ->
case w of
Nothing -> widgetSetSensitive (rightNbIcon mygui) False
_ -> widgetSetSensitive (rightNbIcon mygui) True
-- GUI events -- GUI events
_ <- backViewB myview `on` buttonPressEvent $ do
eb <- eventButton
t <- eventTime
case eb of
LeftButton -> do
liftIO $ void $ goHistoryBack mygui myview
return True
RightButton -> do
his <- liftIO $ readMVar (history myview)
menu <- liftIO $ mkHistoryMenuB mygui myview
(backwardsHistory his)
_ <- liftIO $ menuPopup menu $ Just (RightButton, t)
return True
_ -> return False
_ <- forwardViewB myview `on` buttonPressEvent $ do
eb <- eventButton
t <- eventTime
case eb of
LeftButton -> do
liftIO $ void $ goHistoryForward mygui myview
return True
RightButton -> do
his <- liftIO $ readMVar (history myview)
menu <- liftIO $ mkHistoryMenuF mygui myview
(forwardHistory his)
_ <- liftIO $ menuPopup menu $ Just (RightButton, t)
return True
_ -> return False
_ <- urlBar myview `on` entryActivated $ urlGoTo mygui myview _ <- urlBar myview `on` entryActivated $ urlGoTo mygui myview
_ <- upViewB myview `on` buttonActivated $ _ <- upViewB myview `on` buttonActivated $
upDir mygui myview upDir mygui myview
@ -249,68 +177,69 @@ setViewCallbacks mygui myview = do
goHome mygui myview goHome mygui myview
_ <- refreshViewB myview `on` buttonActivated $ do _ <- refreshViewB myview `on` buttonActivated $ do
cdir <- liftIO $ getCurrentDir myview cdir <- liftIO $ getCurrentDir myview
refreshView mygui myview cdir refreshView' mygui myview cdir
-- key events -- key events
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
ShowHiddenModifier <- eventModifier [Control] <- eventModifier
ShowHiddenKey <- fmap glibToString eventKeyName "h" <- fmap glibToString eventKeyName
cdir <- liftIO $ getCurrentDir myview cdir <- liftIO $ getCurrentDir myview
liftIO $ modifyTVarIO (settings mygui) liftIO $ modifyTVarIO (settings mygui)
(\x -> x { showHidden = not . showHidden $ x}) (\x -> x { showHidden = not . showHidden $ x})
>> refreshView mygui myview cdir >> refreshView' mygui myview cdir
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
UpDirModifier <- eventModifier [Alt] <- eventModifier
UpDirKey <- fmap glibToString eventKeyName "Up" <- fmap glibToString eventKeyName
liftIO $ upDir mygui myview liftIO $ upDir mygui myview
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
HistoryBackModifier <- eventModifier [Alt] <- eventModifier
HistoryBackKey <- fmap glibToString eventKeyName "Left" <- fmap glibToString eventKeyName
liftIO $ void $ goHistoryBack mygui myview liftIO $ goHistoryPrev mygui myview
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
HistoryForwardModifier <- eventModifier [Alt] <- eventModifier
HistoryForwardKey <- fmap glibToString eventKeyName "Right" <- fmap glibToString eventKeyName
liftIO $ void $ goHistoryForward mygui myview liftIO $ goHistoryNext mygui myview
_ <- view `on` keyPressEvent $ tryEvent $ do _ <- view `on` keyPressEvent $ tryEvent $ do
DeleteModifier <- eventModifier "Delete" <- fmap glibToString eventKeyName
DeleteKey <- fmap glibToString eventKeyName
liftIO $ withItems mygui myview del liftIO $ withItems mygui myview del
_ <- view `on` keyPressEvent $ tryEvent $ do _ <- view `on` keyPressEvent $ tryEvent $ do
OpenModifier <- eventModifier [] <- eventModifier
OpenKey <- fmap glibToString eventKeyName "Return" <- fmap glibToString eventKeyName
liftIO $ withItems mygui myview open liftIO $ withItems mygui myview open
_ <- view `on` keyPressEvent $ tryEvent $ do _ <- view `on` keyPressEvent $ tryEvent $ do
CopyModifier <- eventModifier [Control] <- eventModifier
CopyKey <- fmap glibToString eventKeyName "c" <- fmap glibToString eventKeyName
liftIO $ withItems mygui myview copyInit liftIO $ withItems mygui myview copyInit
_ <- view `on` keyPressEvent $ tryEvent $ do _ <- view `on` keyPressEvent $ tryEvent $ do
MoveModifier <- eventModifier [Control] <- eventModifier
MoveKey <- fmap glibToString eventKeyName "x" <- fmap glibToString eventKeyName
liftIO $ withItems mygui myview moveInit liftIO $ withItems mygui myview moveInit
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
PasteModifier <- eventModifier [Control] <- eventModifier
PasteKey <- fmap glibToString eventKeyName "v" <- fmap glibToString eventKeyName
liftIO $ operationFinal mygui myview Nothing liftIO $ operationFinal mygui myview Nothing
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
NewTabModifier <- eventModifier [Control] <- eventModifier
NewTabKey <- fmap glibToString eventKeyName "t" <- fmap glibToString eventKeyName
liftIO $ void $ newTab' mygui myview liftIO $ void $ do
cwd <- getCurrentDir myview
newTab mygui createTreeView (path cwd)
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
CloseTabModifier <- eventModifier [Control] <- eventModifier
CloseTabKey <- fmap glibToString eventKeyName "w" <- fmap glibToString eventKeyName
liftIO $ void $ closeTab mygui myview liftIO $ void $ closeTab mygui myview
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
OpenTerminalModifier <- eventModifier "F4" <- fmap glibToString eventKeyName
OpenTerminalKey <- fmap glibToString eventKeyName
liftIO $ void $ openTerminalHere myview liftIO $ void $ openTerminalHere myview
-- mouse button click -- righ-click
_ <- view `on` buttonPressEvent $ do _ <- view `on` buttonPressEvent $ do
eb <- eventButton eb <- eventButton
t <- eventTime t <- eventTime
case eb of case eb of
RightButton -> do RightButton -> do
_ <- liftIO $ showPopup mygui myview t _ <- liftIO $ menuPopup (rcMenu . rcmenu $ myview)
$ Just (RightButton, t)
-- this is just to not screw with current selection -- this is just to not screw with current selection
-- on right-click -- on right-click
-- TODO: this misbehaves under IconView -- TODO: this misbehaves under IconView
@ -325,32 +254,42 @@ setViewCallbacks mygui myview = do
return $ elem tp selectedTps return $ elem tp selectedTps
-- no item under the cursor, pass on the signal -- no item under the cursor, pass on the signal
Nothing -> return False Nothing -> return False
MiddleButton -> do
(x, y) <- eventCoordinates
mitem <- liftIO $ (getPathAtPos fmv (x, y))
>>= \mpos -> fmap join
$ forM mpos (rawPathToItem myview)
case mitem of
-- item under the cursor, only pass on the signal
-- if the item under the cursor is not within the current
-- selection
(Just item) -> do
liftIO $ opeInNewTab mygui myview item
return True
-- no item under the cursor, pass on the signal
Nothing -> return False
OtherButton 8 -> do OtherButton 8 -> do
liftIO $ void $ goHistoryBack mygui myview liftIO $ goHistoryPrev mygui myview
return False return False
OtherButton 9 -> do OtherButton 9 -> do
liftIO $ void $ goHistoryForward mygui myview liftIO $ goHistoryNext mygui myview
return False return False
-- not right-click, so pass on the signal -- not right-click, so pass on the signal
_ -> return False _ -> return False
-- right click menu
_ <- (rcFileOpen . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview open
_ <- (rcFileExecute . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview execute
_ <- (rcFileNewRegFile . rcmenu) myview `on` menuItemActivated $
liftIO $ newFile mygui myview
_ <- (rcFileNewDir . rcmenu) myview `on` menuItemActivated $
liftIO $ newDir mygui myview
_ <- (rcFileCopy . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview copyInit
_ <- (rcFileRename . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview renameF
_ <- (rcFilePaste . rcmenu) myview `on` menuItemActivated $
liftIO $ operationFinal mygui myview Nothing
_ <- (rcFileDelete . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview del
_ <- (rcFileProperty . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview showFilePropertyDialog
_ <- (rcFileCut . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview moveInit
_ <- (rcFileIconView . rcmenu) myview `on` menuItemActivated $
liftIO $ switchView mygui myview createIconView
_ <- (rcFileTreeView . rcmenu) myview `on` menuItemActivated $
liftIO $ switchView mygui myview createTreeView
return () return ()
getPathAtPos fmv (x, y) = getPathAtPos fmv (x, y) =
case fmv of case fmv of
FMTreeView treeView -> do FMTreeView treeView -> do
@ -369,7 +308,8 @@ setViewCallbacks mygui myview = do
openTerminalHere :: MyView -> IO ProcessID openTerminalHere :: MyView -> IO ProcessID
openTerminalHere myview = do openTerminalHere myview = do
cwd <- (P.fromAbs . path) <$> getCurrentDir myview cwd <- (P.fromAbs . path) <$> getCurrentDir myview
SPP.forkProcess $ terminalCommand cwd -- TODO: make terminal configurable
SPP.forkProcess $ SPP.executeFile "sakura" True ["-d", cwd] Nothing
@ -379,23 +319,9 @@ openTerminalHere myview = do
-- |Closes the current tab, but only if there is more than one tab. -- |Closes the current tab, but only if there is more than one tab.
closeTab :: MyGUI -> MyView -> IO () closeTab :: MyGUI -> MyView -> IO ()
closeTab _ myview = do closeTab mygui myview = do
n <- notebookGetNPages (notebook myview) n <- notebookGetNPages (notebook mygui)
when (n > 1) $ void $ destroyView myview when (n > 1) $ void $ destroyView mygui myview
newTab' :: MyGUI -> MyView -> IO ()
newTab' mygui myview = do
cwd <- getCurrentDir myview
void $ withErrorDialog
$ newTab mygui (notebook myview) createTreeView cwd (-1)
opeInNewTab :: MyGUI -> MyView -> Item -> IO ()
opeInNewTab mygui myview item@(DirOrSym _) =
void $ withErrorDialog
$ newTab mygui (notebook myview) createTreeView item (-1)
opeInNewTab _ _ _ = return ()
@ -414,8 +340,8 @@ del items@(_:_) _ _ = withErrorDialog $ do
withConfirmationDialog cmsg withConfirmationDialog cmsg
$ forM_ items $ \item -> easyDelete . path $ item $ forM_ items $ \item -> easyDelete . path $ item
del _ _ _ = withErrorDialog del _ _ _ = withErrorDialog
. ioError $ userError . throw $ InvalidOperation
"Operation not supported on multiple files" "Operation not supported on multiple files"
-- |Initializes a file move operation. -- |Initializes a file move operation.
@ -429,8 +355,8 @@ moveInit items@(_:_) mygui _ = do
popStatusbar mygui popStatusbar mygui
void $ pushStatusBar mygui sbmsg void $ pushStatusBar mygui sbmsg
moveInit _ _ _ = withErrorDialog moveInit _ _ _ = withErrorDialog
. ioError $ userError . throw $ InvalidOperation
"No file selected!" "No file selected!"
-- |Supposed to be used with 'withRows'. Initializes a file copy operation. -- |Supposed to be used with 'withRows'. Initializes a file copy operation.
copyInit :: [Item] -> MyGUI -> MyView -> IO () copyInit :: [Item] -> MyGUI -> MyView -> IO ()
@ -443,8 +369,8 @@ copyInit items@(_:_) mygui _ = do
popStatusbar mygui popStatusbar mygui
void $ pushStatusBar mygui sbmsg void $ pushStatusBar mygui sbmsg
copyInit _ _ _ = withErrorDialog copyInit _ _ _ = withErrorDialog
. ioError $ userError . throw $ InvalidOperation
"No file selected!" "No file selected!"
-- |Finalizes a file operation, such as copy or move. -- |Finalizes a file operation, such as copy or move.
@ -457,20 +383,20 @@ operationFinal mygui myview mitem = withErrorDialog $ do
case op of case op of
FMove (PartialMove s) -> do FMove (PartialMove s) -> do
let cmsg = "Really move " ++ imsg s let cmsg = "Really move " ++ imsg s
++ " to \"" ++ toString (P.fromAbs cdir) ++ " to \"" ++ P.fpToString (P.fromAbs cdir)
++ "\"?" ++ "\"?"
withConfirmationDialog cmsg $ doFileOperation (FMove $ Move s cdir) withConfirmationDialog cmsg $ doFileOperation (FMove $ Move s cdir)
popStatusbar mygui popStatusbar mygui
writeTVarIO (operationBuffer mygui) None writeTVarIO (operationBuffer mygui) None
FCopy (PartialCopy s) -> do FCopy (PartialCopy s) -> do
let cmsg = "Really copy " ++ imsg s let cmsg = "Really copy " ++ imsg s
++ " to \"" ++ toString (P.fromAbs cdir) ++ " to \"" ++ P.fpToString (P.fromAbs cdir)
++ "\"?" ++ "\"?"
withConfirmationDialog cmsg $ doFileOperation (FCopy $ Copy s cdir) withConfirmationDialog cmsg $ doFileOperation (FCopy $ Copy s cdir)
_ -> return () _ -> return ()
where where
imsg s = case s of imsg s = case s of
(item:[]) -> "\"" ++ toString (P.fromAbs item) ++ "\"" (item:[]) -> "\"" ++ P.fpToString (P.fromAbs item) ++ "\""
items -> (show . length $ items) ++ " items" items -> (show . length $ items) ++ " items"
@ -478,38 +404,38 @@ operationFinal mygui myview mitem = withErrorDialog $ do
newFile :: MyGUI -> MyView -> IO () newFile :: MyGUI -> MyView -> IO ()
newFile _ myview = withErrorDialog $ do newFile _ myview = withErrorDialog $ do
mfn <- textInputDialog "Enter file name" ("" :: String) mfn <- textInputDialog "Enter file name" ("" :: String)
let pmfn = P.parseRel =<< fromString <$> mfn let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
for_ pmfn $ \fn -> do for_ pmfn $ \fn -> do
cdir <- getCurrentDir myview cdir <- getCurrentDir myview
createRegularFile newFilePerms (path cdir P.</> fn) createRegularFile (path cdir P.</> fn)
-- |Create a new directory. -- |Create a new directory.
newDir :: MyGUI -> MyView -> IO () newDir :: MyGUI -> MyView -> IO ()
newDir _ myview = withErrorDialog $ do newDir _ myview = withErrorDialog $ do
mfn <- textInputDialog "Enter directory name" ("" :: String) mfn <- textInputDialog "Enter directory name" ("" :: String)
let pmfn = P.parseRel =<< fromString <$> mfn let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
for_ pmfn $ \fn -> do for_ pmfn $ \fn -> do
cdir <- getCurrentDir myview cdir <- getCurrentDir myview
createDir newDirPerms (path cdir P.</> fn) createDir (path cdir P.</> fn)
renameF :: [Item] -> MyGUI -> MyView -> IO () renameF :: [Item] -> MyGUI -> MyView -> IO ()
renameF [item] _ _ = withErrorDialog $ do renameF [item] _ _ = withErrorDialog $ do
iname <- P.fromRel <$> (P.basename $ path item) iname <- P.fromRel <$> (P.basename $ path item)
mfn <- textInputDialog "Enter new file name" (iname :: ByteString) mfn <- textInputDialog "Enter new file name" (iname :: ByteString)
let pmfn = P.parseRel =<< fromString <$> mfn let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
for_ pmfn $ \fn -> do for_ pmfn $ \fn -> do
let cmsg = "Really rename \"" ++ getFPasStr item let cmsg = "Really rename \"" ++ getFPasStr item
++ "\"" ++ " to \"" ++ "\"" ++ " to \""
++ toString (P.fromAbs $ (P.dirname . path $ item) ++ P.fpToString (P.fromAbs $ (P.dirname . path $ item)
P.</> fn) ++ "\"?" P.</> fn) ++ "\"?"
withConfirmationDialog cmsg $ withConfirmationDialog cmsg $
HPath.IO.renameFile (path item) HSFM.FileSystem.FileOperations.renameFile (path item)
((P.dirname $ path item) P.</> fn) ((P.dirname $ path item) P.</> fn)
renameF _ _ _ = withErrorDialog renameF _ _ _ = withErrorDialog
. ioError $ userError . throw $ InvalidOperation
"Operation not supported on multiple files" "Operation not supported on multiple files"
@ -526,15 +452,15 @@ urlGoTo mygui myview = withErrorDialog $ do
fp <- entryGetText (urlBar myview) fp <- entryGetText (urlBar myview)
forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' -> forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' ->
whenM (canOpenDirectory fp') whenM (canOpenDirectory fp')
(goDir True mygui myview =<< (pathToFile getFileInfo $ fp')) (goDir mygui myview =<< (readFile getFileInfo $ fp'))
goHome :: MyGUI -> MyView -> IO () goHome :: MyGUI -> MyView -> IO ()
goHome mygui myview = withErrorDialog $ do goHome mygui myview = withErrorDialog $ do
homedir <- home mhomedir <- getEnv "HOME"
forM_ (P.parseAbs homedir :: Maybe (Path Abs)) $ \fp' -> forM_ (P.parseAbs =<< mhomedir :: Maybe (Path Abs)) $ \fp' ->
whenM (canOpenDirectory fp') whenM (canOpenDirectory fp')
(goDir True mygui myview =<< (pathToFile getFileInfo $ fp')) (goDir mygui myview =<< (readFile getFileInfo $ fp'))
-- |Execute a given file. -- |Execute a given file.
@ -542,8 +468,8 @@ execute :: [Item] -> MyGUI -> MyView -> IO ()
execute [item] _ _ = withErrorDialog $ execute [item] _ _ = withErrorDialog $
void $ executeFile (path item) [] void $ executeFile (path item) []
execute _ _ _ = withErrorDialog execute _ _ _ = withErrorDialog
. ioError $ userError . throw $ InvalidOperation
"Operation not supported on multiple files" "Operation not supported on multiple files"
-- |Supposed to be used with 'withRows'. Opens a file or directory. -- |Supposed to be used with 'withRows'. Opens a file or directory.
@ -551,15 +477,16 @@ open :: [Item] -> MyGUI -> MyView -> IO ()
open [item] mygui myview = withErrorDialog $ open [item] mygui myview = withErrorDialog $
case item of case item of
DirOrSym r -> do DirOrSym r -> do
nv <- pathToFile getFileInfo $ path r nv <- readFile getFileInfo $ path r
goDir True mygui myview nv goDir mygui myview nv
r -> r ->
void $ openFile . path $ r void $ openFile . path $ r
open items mygui myview = do -- this throws on the first error that occurs
let dirs = filter (fst . sdir) items open (FileLikeList fs) _ _ = withErrorDialog $
files = filter (fst . sfileLike) items forM_ fs $ \f -> void $ openFile . path $ f
forM_ dirs (withErrorDialog . opeInNewTab mygui myview) open _ _ _ = withErrorDialog
forM_ files (withErrorDialog . openFile . path) . throw $ InvalidOperation
"Operation not supported on multiple files"
-- |Go up one directory and visualize it in the treeView. -- |Go up one directory and visualize it in the treeView.
@ -567,162 +494,33 @@ upDir :: MyGUI -> MyView -> IO ()
upDir mygui myview = withErrorDialog $ do upDir mygui myview = withErrorDialog $ do
cdir <- getCurrentDir myview cdir <- getCurrentDir myview
nv <- goUp cdir nv <- goUp cdir
goDir True mygui myview nv goDir mygui myview nv
---- HISTORY CALLBACKS ----
-- |Go "back" in the history. -- |Go "back" in the history.
goHistoryBack :: MyGUI -> MyView -> IO (Path Abs) goHistoryPrev :: MyGUI -> MyView -> IO ()
goHistoryBack mygui myview = do goHistoryPrev mygui myview = do
hs <- takeMVar (history myview) hs <- readTVarIO (history myview)
let nhs = historyBack hs case hs of
putMVar (history myview) nhs ([], _) -> return ()
nv <- pathToFile getFileInfo $ currentDir nhs (x:xs, _) -> do
goDir False mygui myview nv cdir <- getCurrentDir myview
return $ currentDir nhs nv <- readFile getFileInfo $ x
modifyTVarIO (history myview)
(\(_, n) -> (xs, path cdir `addHistory` n))
refreshView' mygui myview nv
-- |Go "forward" in the history. -- |Go "forth" in the history.
goHistoryForward :: MyGUI -> MyView -> IO (Path Abs) goHistoryNext :: MyGUI -> MyView -> IO ()
goHistoryForward mygui myview = do goHistoryNext mygui myview = do
hs <- takeMVar (history myview) hs <- readTVarIO (history myview)
let nhs = historyForward hs case hs of
putMVar (history myview) nhs (_, []) -> return ()
nv <- pathToFile getFileInfo $ currentDir nhs (_, x:xs) -> do
goDir False mygui myview nv cdir <- getCurrentDir myview
return $ currentDir nhs nv <- readFile getFileInfo $ x
modifyTVarIO (history myview)
(\(p, _) -> (path cdir `addHistory` p, xs))
-- |Show backwards history in a drop-down menu, depending on the input. refreshView' mygui myview nv
mkHistoryMenuB :: MyGUI -> MyView -> [Path Abs] -> IO Menu
mkHistoryMenuB mygui myview hs = do
menu <- menuNew
menuitems <- forM hs $ \p -> do
item <- menuItemNewWithLabel (fromAbs p)
_ <- item `on` menuItemActivated $
void $ iterateUntil (== p) (goHistoryBack mygui myview)
return item
forM_ menuitems $ \item -> menuShellAppend menu item
widgetShowAll menu
return menu
-- |Show forward history in a drop-down menu, depending on the input.
mkHistoryMenuF :: MyGUI -> MyView -> [Path Abs] -> IO Menu
mkHistoryMenuF mygui myview hs = do
menu <- menuNew
menuitems <- forM hs $ \p -> do
item <- menuItemNewWithLabel (fromAbs p)
_ <- item `on` menuItemActivated $
void $ iterateUntil (== p) (goHistoryForward mygui myview)
return item
forM_ menuitems $ \item -> menuShellAppend menu item
widgetShowAll menu
return menu
---- RIGHTCLICK CALLBACKS ----
-- |TODO: hopefully this does not leak
showPopup :: MyGUI -> MyView -> TimeStamp -> IO ()
showPopup mygui myview t
| null myplugins = return ()
| otherwise = do
rcmenu <- doRcMenu
-- add common callbacks
_ <- (\_ -> rcFileOpen rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview open
_ <- (rcFileExecute rcmenu) `on` menuItemActivated $
liftIO $ withItems mygui myview execute
_ <- (rcFileNewRegFile rcmenu) `on` menuItemActivated $
liftIO $ newFile mygui myview
_ <- (rcFileNewDir rcmenu) `on` menuItemActivated $
liftIO $ newDir mygui myview
_ <- (rcFileNewTab rcmenu) `on` menuItemActivated $
liftIO $ newTab' mygui myview
_ <- (rcFileNewTerm rcmenu) `on` menuItemActivated $
liftIO $ void $ openTerminalHere myview
_ <- (rcFileCopy rcmenu) `on` menuItemActivated $
liftIO $ withItems mygui myview copyInit
_ <- (rcFileRename rcmenu) `on` menuItemActivated $
liftIO $ withItems mygui myview renameF
_ <- (rcFilePaste rcmenu) `on` menuItemActivated $
liftIO $ operationFinal mygui myview Nothing
_ <- (rcFileDelete rcmenu) `on` menuItemActivated $
liftIO $ withItems mygui myview del
_ <- (rcFileProperty rcmenu) `on` menuItemActivated $
liftIO $ withItems mygui myview showFilePropertyDialog
_ <- (rcFileCut rcmenu) `on` menuItemActivated $
liftIO $ withItems mygui myview moveInit
_ <- (rcFileIconView rcmenu) `on` menuItemActivated $
liftIO $ switchView mygui myview createIconView
_ <- (rcFileTreeView rcmenu) `on` menuItemActivated $
liftIO $ switchView mygui myview createTreeView
-- add another plugin separator after the existing one
-- where we want to place our plugins
sep2 <- separatorMenuItemNew
widgetShow sep2
menuShellInsert (rcMenu rcmenu) sep2 insertPos
plugins <- forM myplugins $ \(ma, mb, mc) -> fmap (, mb, mc) ma
-- need to reverse plugins list so the order is right
forM_ (reverse plugins) $ \(plugin, filter', cb) -> do
showItem <- withItems mygui myview filter'
menuShellInsert (rcMenu rcmenu) plugin insertPos
when showItem $ widgetShow plugin
-- init callback
plugin `on` menuItemActivated $ withItems mygui myview cb
menuPopup (rcMenu rcmenu) $ Just (RightButton, t)
where
doRcMenu = do
builder <- builderNew
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
-- create static right-click menu
rcMenu <- builderGetObject builder castToMenu
(fromString "rcMenu")
rcFileOpen <- builderGetObject builder castToImageMenuItem
(fromString "rcFileOpen")
rcFileExecute <- builderGetObject builder castToImageMenuItem
(fromString "rcFileExecute")
rcFileNewRegFile <- builderGetObject builder castToImageMenuItem
(fromString "rcFileNewRegFile")
rcFileNewDir <- builderGetObject builder castToImageMenuItem
(fromString "rcFileNewDir")
rcFileNewTab <- builderGetObject builder castToImageMenuItem
(fromString "rcFileNewTab")
rcFileNewTerm <- builderGetObject builder castToImageMenuItem
(fromString "rcFileNewTerm")
rcFileCut <- builderGetObject builder castToImageMenuItem
(fromString "rcFileCut")
rcFileCopy <- builderGetObject builder castToImageMenuItem
(fromString "rcFileCopy")
rcFileRename <- builderGetObject builder castToImageMenuItem
(fromString "rcFileRename")
rcFilePaste <- builderGetObject builder castToImageMenuItem
(fromString "rcFilePaste")
rcFileDelete <- builderGetObject builder castToImageMenuItem
(fromString "rcFileDelete")
rcFileProperty <- builderGetObject builder castToImageMenuItem
(fromString "rcFileProperty")
rcFileIconView <- builderGetObject builder castToImageMenuItem
(fromString "rcFileIconView")
rcFileTreeView <- builderGetObject builder castToImageMenuItem
(fromString "rcFileTreeView")
return $ MkRightClickMenu {..}

98
src/HSFM/GUI/Gtk/Callbacks/Utils.hs
View File

@ -16,6 +16,7 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--} --}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
@ -26,103 +27,76 @@ module HSFM.GUI.Gtk.Callbacks.Utils where
import Control.Monad import Control.Monad
( (
forM_ forM_
, when
)
import Data.Foldable
(
for_
)
import Data.Maybe
(
fromJust
) )
import GHC.IO.Exception import GHC.IO.Exception
( (
IOErrorType(..) IOErrorType(..)
) )
import Graphics.UI.Gtk
import qualified HPath as P import qualified HPath as P
import HPath.IO import HSFM.FileSystem.Errors
import HPath.IO.Errors import HSFM.FileSystem.FileOperations
import HSFM.FileSystem.FileType import HSFM.FileSystem.FileType
import qualified HSFM.FileSystem.UtilTypes as UT import HSFM.FileSystem.UtilTypes
import HSFM.GUI.Gtk.Data import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Dialogs import HSFM.GUI.Gtk.Dialogs
import HSFM.GUI.Gtk.MyView import HSFM.GUI.Gtk.MyView
import HSFM.History import HSFM.GUI.Gtk.Utils
import Prelude hiding(readFile) import HSFM.Utils.IO
import Control.Concurrent.MVar
( (
putMVar modifyTVarIO
, tryTakeMVar
) )
import Prelude hiding(readFile)
-- |Carries out a file operation with the appropriate error handling -- |Carries out a file operation with the appropriate error handling
-- allowing the user to react to various exceptions with further input. -- allowing the user to react to various exceptions with further input.
doFileOperation :: UT.FileOperation -> IO () doFileOperation :: FileOperation -> IO ()
doFileOperation (UT.FCopy (UT.Copy (f':fs') to)) = doFileOperation (FCopy (Copy (f':fs') to)) =
_doFileOperation (f':fs') to (\p1 p2 cm -> easyCopy p1 p2 cm FailEarly) _doFileOperation (f':fs') to easyCopyOverwrite easyCopy
$ doFileOperation (UT.FCopy $ UT.Copy fs' to) $ doFileOperation (FCopy $ Copy fs' to)
doFileOperation (UT.FMove (UT.Move (f':fs') to)) = doFileOperation (FMove (Move (f':fs') to)) =
_doFileOperation (f':fs') to moveFile _doFileOperation (f':fs') to moveFileOverwrite moveFile
$ doFileOperation (UT.FMove $ UT.Move fs' to) $ doFileOperation (FMove $ Move fs' to)
where
doFileOperation _ = return () doFileOperation _ = return ()
_doFileOperation :: [P.Path b1] _doFileOperation :: [P.Path b1]
-> P.Path P.Abs -> P.Path P.Abs
-> (P.Path b1 -> P.Path P.Abs -> CopyMode -> IO b) -> (P.Path b1 -> P.Path P.Abs -> IO b)
-> (P.Path b1 -> P.Path P.Abs -> IO a)
-> IO () -> IO ()
-> IO () -> IO ()
_doFileOperation [] _ _ _ = return () _doFileOperation [] _ _ _ _ = return ()
_doFileOperation (f:fs) to mc rest = do _doFileOperation (f:fs) to mcOverwrite mc rest = do
toname <- P.basename f toname <- P.basename f
let topath = to P.</> toname let topath = to P.</> toname
reactOnError (mc f topath Strict >> rest) reactOnError (mc f topath >> rest)
-- TODO: how safe is 'AlreadyExists' here?
[(AlreadyExists , collisionAction fileCollisionDialog topath)] [(AlreadyExists , collisionAction fileCollisionDialog topath)]
[(SameFile{} , collisionAction renameDialog topath)] [(FileDoesExist{}, collisionAction fileCollisionDialog topath)
,(DirDoesExist{} , collisionAction fileCollisionDialog topath)
,(SameFile{} , collisionAction renameDialog topath)]
where where
collisionAction diag topath = do collisionAction diag topath = do
mcm <- diag . P.fromAbs $ topath mcm <- diag . P.fromAbs $ topath
forM_ mcm $ \cm -> case cm of forM_ mcm $ \cm -> case cm of
UT.Overwrite -> mc f topath Overwrite >> rest Overwrite -> mcOverwrite f topath >> rest
UT.OverwriteAll -> forM_ (f:fs) $ \x -> do OverwriteAll -> forM_ (f:fs) $ \x -> do
toname' <- P.basename x toname' <- P.basename x
mc x (to P.</> toname') Overwrite mcOverwrite x (to P.</> toname')
UT.Skip -> rest Skip -> rest
UT.Rename newn -> mc f (to P.</> newn) Strict >> rest Rename newn -> mc f (to P.</> newn) >> rest
_ -> return () _ -> return ()
-- |Helper that is invoked for any directory change operations. -- |Helper that is invoked for any directory change operations.
goDir :: Bool -- ^ whether to update the history goDir :: MyGUI -> MyView -> Item -> IO ()
-> MyGUI goDir mygui myview item = do
-> MyView cdir <- getCurrentDir myview
-> Item modifyTVarIO (history myview)
-> IO () (\(p, _) -> (path cdir `addHistory` p, []))
goDir bhis mygui myview item = do refreshView' mygui myview item
when bhis $ do
mhs <- tryTakeMVar (history myview)
for_ mhs $ \hs -> do
let nhs = historyNewPath (path item) hs
putMVar (history myview) nhs
refreshView mygui myview item
-- set notebook tab label
page <- notebookGetCurrentPage (notebook myview)
child <- fromJust <$> notebookGetNthPage (notebook myview) page
-- get the label
ebox <- (castToEventBox . fromJust)
<$> notebookGetTabLabel (notebook myview) child
label <- (castToLabel . head) <$> containerGetChildren ebox
-- set the label
labelSetText label
(maybe (P.fromAbs $ path item)
P.fromRel $ P.basename . path $ item)

23
src/HSFM/GUI/Gtk/Data.hs
View File

@ -30,9 +30,13 @@ import Control.Concurrent.STM
TVar TVar
) )
import Graphics.UI.Gtk hiding (MenuBar) import Graphics.UI.Gtk hiding (MenuBar)
import HPath
(
Abs
, Path
)
import HSFM.FileSystem.FileType import HSFM.FileSystem.FileType
import HSFM.FileSystem.UtilTypes import HSFM.FileSystem.UtilTypes
import HSFM.History
import System.INotify import System.INotify
( (
INotify INotify
@ -57,14 +61,7 @@ data MyGUI = MkMyGUI {
, menubar :: !MenuBar , menubar :: !MenuBar
, statusBar :: !Statusbar , statusBar :: !Statusbar
, clearStatusBar :: !Button , clearStatusBar :: !Button
, notebook :: !Notebook
, notebook1 :: !Notebook
, leftNbBtn :: !ToggleButton
, leftNbIcon :: !Image
, notebook2 :: !Notebook
, rightNbBtn :: !ToggleButton
, rightNbIcon :: !Image
-- other -- other
, fprop :: !FilePropertyGrid , fprop :: !FilePropertyGrid
@ -83,18 +80,16 @@ data MyView = MkMyView {
, sortedModel :: !(TVar (TypedTreeModelSort Item)) , sortedModel :: !(TVar (TypedTreeModelSort Item))
, filteredModel :: !(TVar (TypedTreeModelFilter Item)) , filteredModel :: !(TVar (TypedTreeModelFilter Item))
, inotify :: !(MVar INotify) , inotify :: !(MVar INotify)
, notebook :: !Notebook -- current notebook
-- the first part of the tuple represents the "go back" -- the first part of the tuple represents the "go back"
-- the second part the "go forth" in the history -- the second part the "go forth" in the history
, history :: !(MVar BrowsingHistory) , history :: !(TVar ([Path Abs], [Path Abs]))
-- sub-widgets -- sub-widgets
, scroll :: !ScrolledWindow , scroll :: !ScrolledWindow
, viewBox :: !Box , viewBox :: !Box
, backViewB :: !Button , rcmenu :: !RightClickMenu
, upViewB :: !Button , upViewB :: !Button
, forwardViewB :: !Button
, homeViewB :: !Button , homeViewB :: !Button
, refreshViewB :: !Button , refreshViewB :: !Button
, urlBar :: !Entry , urlBar :: !Entry
@ -112,8 +107,6 @@ data RightClickMenu = MkRightClickMenu {
, rcFileExecute :: !ImageMenuItem , rcFileExecute :: !ImageMenuItem
, rcFileNewRegFile :: !ImageMenuItem , rcFileNewRegFile :: !ImageMenuItem
, rcFileNewDir :: !ImageMenuItem , rcFileNewDir :: !ImageMenuItem
, rcFileNewTab :: !ImageMenuItem
, rcFileNewTerm :: !ImageMenuItem
, rcFileCut :: !ImageMenuItem , rcFileCut :: !ImageMenuItem
, rcFileCopy :: !ImageMenuItem , rcFileCopy :: !ImageMenuItem
, rcFileRename :: !ImageMenuItem , rcFileRename :: !ImageMenuItem

72
src/HSFM/GUI/Gtk/Dialogs.hs
View File

@ -16,22 +16,17 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--} --}
{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.Dialogs where module HSFM.GUI.Gtk.Dialogs where
import Codec.Binary.UTF8.String
(
decodeString
)
import Control.Exception import Control.Exception
( (
catches displayException
, displayException , throw
, throwIO
, IOException , IOException
, catches
, Handler(..) , Handler(..)
) )
import Control.Monad import Control.Monad
@ -49,39 +44,23 @@ import Data.ByteString.UTF8
( (
fromString fromString
) )
import Distribution.Package
(
PackageIdentifier(..)
, packageVersion
, unPackageName
)
#if MIN_VERSION_Cabal(2,0,0)
import Distribution.Version
(
showVersion
)
#else
import Data.Version import Data.Version
( (
showVersion showVersion
) )
#endif import Distribution.Package
(
PackageIdentifier(..)
, PackageName(..)
)
import Distribution.PackageDescription import Distribution.PackageDescription
( (
GenericPackageDescription(..) GenericPackageDescription(..)
, PackageDescription(..) , PackageDescription(..)
) )
#if MIN_VERSION_Cabal(2,2,0)
import Distribution.PackageDescription.Parsec
#else
import Distribution.PackageDescription.Parse import Distribution.PackageDescription.Parse
#endif
( (
#if MIN_VERSION_Cabal(2,0,0) readPackageDescription
readGenericPackageDescription,
#else
readPackageDescription,
#endif
) )
import Distribution.Verbosity import Distribution.Verbosity
( (
@ -89,7 +68,7 @@ import Distribution.Verbosity
) )
import Graphics.UI.Gtk import Graphics.UI.Gtk
import qualified HPath as P import qualified HPath as P
import HPath.IO.Errors import HSFM.FileSystem.Errors
import HSFM.FileSystem.FileType import HSFM.FileSystem.FileType
import HSFM.FileSystem.UtilTypes import HSFM.FileSystem.UtilTypes
import HSFM.GUI.Glib.GlibString() import HSFM.GUI.Glib.GlibString()
@ -114,6 +93,7 @@ import System.Posix.FilePath
--------------------- ---------------------
--[ Dialog popups ]-- --[ Dialog popups ]--
--------------------- ---------------------
@ -171,9 +151,9 @@ fileCollisionDialog t = do
ResponseUser 4 -> do ResponseUser 4 -> do
mfn <- textInputDialog (fromString "Enter new name") (takeFileName t) mfn <- textInputDialog (fromString "Enter new name") (takeFileName t)
forM mfn $ \fn -> do forM mfn $ \fn -> do
pfn <- P.parseRel (fromString fn) pfn <- P.parseFn (P.userStringToFP fn)
return $ Rename pfn return $ Rename pfn
_ -> throwIO UnknownDialogButton _ -> throw UnknownDialogButton
renameDialog :: ByteString -> IO (Maybe FCollisonMode) renameDialog :: ByteString -> IO (Maybe FCollisonMode)
@ -196,9 +176,9 @@ renameDialog t = do
ResponseUser 2 -> do ResponseUser 2 -> do
mfn <- textInputDialog (fromString "Enter new name") (takeFileName t) mfn <- textInputDialog (fromString "Enter new name") (takeFileName t)
forM mfn $ \fn -> do forM mfn $ \fn -> do
pfn <- P.parseRel (fromString fn) pfn <- P.parseFn (P.userStringToFP fn)
return $ Rename pfn return $ Rename pfn
_ -> throwIO UnknownDialogButton _ -> throw UnknownDialogButton
-- |Shows the about dialog from the help menu. -- |Shows the about dialog from the help menu.
@ -208,16 +188,12 @@ showAboutDialog = do
lstr <- Prelude.readFile =<< getDataFileName "LICENSE" lstr <- Prelude.readFile =<< getDataFileName "LICENSE"
hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png" hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png"
pdesc <- fmap packageDescription pdesc <- fmap packageDescription
#if MIN_VERSION_Cabal(2,0,0)
(readGenericPackageDescription silent
#else
(readPackageDescription silent (readPackageDescription silent
#endif
=<< getDataFileName "hsfm.cabal") =<< getDataFileName "hsfm.cabal")
set ad set ad
[ aboutDialogProgramName := (unPackageName . pkgName . package) pdesc [ aboutDialogProgramName := (unPackageName . pkgName . package) pdesc
, aboutDialogName := (unPackageName . pkgName . package) pdesc , aboutDialogName := (unPackageName . pkgName . package) pdesc
, aboutDialogVersion := (showVersion . packageVersion . package) pdesc , aboutDialogVersion := (showVersion . pkgVersion . package) pdesc
, aboutDialogCopyright := copyright pdesc , aboutDialogCopyright := copyright pdesc
, aboutDialogComments := description pdesc , aboutDialogComments := description pdesc
, aboutDialogLicense := Just lstr , aboutDialogLicense := Just lstr
@ -244,19 +220,17 @@ withErrorDialog :: IO a -> IO ()
withErrorDialog io = withErrorDialog io =
catches (void io) catches (void io)
[ Handler (\e -> showErrorDialog [ Handler (\e -> showErrorDialog
. decodeString $ displayException (e :: IOException))
. displayException
$ (e :: IOException))
, Handler (\e -> showErrorDialog , Handler (\e -> showErrorDialog
$ displayException (e :: HPathIOException)) $ displayException (e :: FmIOException))
] ]
-- |Asks the user which directory copy mode he wants via dialog popup -- |Asks the user which directory copy mode he wants via dialog popup
-- and returns 'DirCopyMode'. -- and returns 'DirCopyMode'.
textInputDialog :: (GlibString s1, GlibString s2) textInputDialog :: GlibString string
=> s1 -- ^ window title => string -- ^ window title
-> s2 -- ^ initial text in input widget -> string -- ^ initial text in input widget
-> IO (Maybe String) -> IO (Maybe String)
textInputDialog title inittext = do textInputDialog title inittext = do
chooserDialog <- messageDialogNew Nothing chooserDialog <- messageDialogNew Nothing
@ -276,7 +250,7 @@ textInputDialog title inittext = do
-- TODO: make this more safe -- TODO: make this more safe
ResponseUser 0 -> Just <$> entryGetText entry ResponseUser 0 -> Just <$> entryGetText entry
ResponseUser 1 -> return Nothing ResponseUser 1 -> return Nothing
_ -> throwIO UnknownDialogButton _ -> throw UnknownDialogButton
widgetDestroy chooserDialog widgetDestroy chooserDialog
return ret return ret
@ -295,7 +269,7 @@ showFilePropertyDialog [item] mygui _ = do
entrySetText (fpropFnEntry fprop') (maybe BS.empty P.fromRel entrySetText (fpropFnEntry fprop') (maybe BS.empty P.fromRel
$ P.basename . path $ item) $ P.basename . path $ item)
entrySetText (fpropLocEntry fprop') (P.fromAbs . P.dirname . path $ item) entrySetText (fpropLocEntry fprop') (P.fromAbs . P.dirname . path $ item)
entrySetText (fpropTsEntry fprop') (show . fileSize $ fvar item) entrySetText (fpropTsEntry fprop') (fromFreeVar (show . fileSize) item)
entrySetText (fpropModEntry fprop') (packModTime item) entrySetText (fpropModEntry fprop') (packModTime item)
entrySetText (fpropAcEntry fprop') (packAccessTime item) entrySetText (fpropAcEntry fprop') (packAccessTime item)
entrySetText (fpropFTEntry fprop') (packFileType item) entrySetText (fpropFTEntry fprop') (packFileType item)

29
src/HSFM/GUI/Gtk/MyGUI.hs
View File

@ -45,6 +45,7 @@ import Paths_hsfm
-- |Set up the GUI. This only creates the permanent widgets. -- |Set up the GUI. This only creates the permanent widgets.
createMyGUI :: IO MyGUI createMyGUI :: IO MyGUI
createMyGUI = do createMyGUI = do
let settings' = MkFMSettings False True 24 let settings' = MkFMSettings False True 24
settings <- newTVarIO settings' settings <- newTVarIO settings'
operationBuffer <- newTVarIO None operationBuffer <- newTVarIO None
@ -81,32 +82,8 @@ createMyGUI = do
"fpropPermEntry" "fpropPermEntry"
fpropLDEntry <- builderGetObject builder castToEntry fpropLDEntry <- builderGetObject builder castToEntry
"fpropLDEntry" "fpropLDEntry"
notebook1 <- builderGetObject builder castToNotebook notebook <- builderGetObject builder castToNotebook
"notebook1" "notebook"
notebook2 <- builderGetObject builder castToNotebook
"notebook2"
leftNbIcon <- builderGetObject builder castToImage
"leftNbIcon"
rightNbIcon <- builderGetObject builder castToImage
"rightNbIcon"
leftNbBtn <- builderGetObject builder castToToggleButton
"leftNbBtn"
rightNbBtn <- builderGetObject builder castToToggleButton
"rightNbBtn"
-- this is required so that hotkeys work as expected, because
-- we then can connect to signals from `viewBox` more reliably
widgetSetCanFocus notebook1 False
widgetSetCanFocus notebook2 False
-- notebook toggle buttons
buttonSetImage leftNbBtn leftNbIcon
buttonSetImage rightNbBtn rightNbIcon
widgetSetSensitive leftNbIcon False
widgetSetSensitive rightNbIcon False
toggleButtonSetActive leftNbBtn True
toggleButtonSetActive rightNbBtn True
-- construct the gui object -- construct the gui object
let menubar = MkMenuBar {..} let menubar = MkMenuBar {..}

202
src/HSFM/GUI/Gtk/MyView.hs
View File

@ -16,7 +16,6 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--} --}
{-# LANGUAGE RecordWildCards #-}
module HSFM.GUI.Gtk.MyView where module HSFM.GUI.Gtk.MyView where
@ -33,15 +32,10 @@ import Control.Concurrent.STM
newTVarIO newTVarIO
, readTVarIO , readTVarIO
) )
import Control.Monad import Control.Exception
( (
unless try
, void , SomeException
, when
)
import Control.Monad.IO.Class
(
liftIO
) )
import Data.Foldable import Data.Foldable
( (
@ -52,19 +46,23 @@ import Data.Maybe
catMaybes catMaybes
, fromJust , fromJust
) )
import Data.String import HSFM.FileSystem.Errors
( (
fromString canOpenDirectory
) )
import Graphics.UI.Gtk import Graphics.UI.Gtk
import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setViewCallbacks) import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setViewCallbacks)
import HPath
(
Path
, Abs
)
import qualified HPath as P import qualified HPath as P
import HSFM.FileSystem.FileType import HSFM.FileSystem.FileType
import HSFM.GUI.Glib.GlibString() import HSFM.GUI.Glib.GlibString()
import HSFM.GUI.Gtk.Data import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Icons import HSFM.GUI.Gtk.Icons
import HSFM.GUI.Gtk.Utils import HSFM.GUI.Gtk.Utils
import HSFM.History
import HSFM.Utils.IO import HSFM.Utils.IO
import Paths_hsfm import Paths_hsfm
( (
@ -78,72 +76,27 @@ import System.INotify
, killINotify , killINotify
, EventVariety(..) , EventVariety(..)
) )
import System.IO.Error
(
catchIOError
, ioError
, isUserError
)
import System.Posix.FilePath
(
hiddenFile
)
-- |Creates a new tab with its own view and refreshes the view. -- |Creates a new tab with its own view and refreshes the view.
newTab :: MyGUI -> Notebook -> IO FMView -> Item -> Int -> IO MyView newTab :: MyGUI -> IO FMView -> Path Abs -> IO MyView
newTab mygui nb iofmv item pos = do newTab mygui iofmv path = do
myview <- createMyView mygui iofmv
_ <- notebookAppendPage (notebook mygui) (viewBox myview)
-- create eventbox with label (maybe (P.fromAbs path) P.fromRel $ P.basename path)
label <- labelNewWithMnemonic refreshView mygui myview (Just path)
(maybe (P.fromAbs $ path item) P.fromRel $ P.basename $ path item)
ebox <- eventBoxNew
eventBoxSetVisibleWindow ebox False
containerAdd ebox label
widgetShowAll label
myview <- createMyView mygui nb iofmv
_ <- notebookInsertPageMenu (notebook myview) (viewBox myview)
ebox ebox pos
-- set initial history
let historySize = 5
putMVar (history myview)
(BrowsingHistory [] (path item) [] historySize)
notebookSetTabReorderable (notebook myview) (viewBox myview) True
catchIOError (refreshView mygui myview item) $ \e -> do
file <- pathToFile getFileInfo . fromJust . P.parseAbs . fromString
$ "/"
refreshView mygui myview file
labelSetText label (fromString "/" :: String)
unless (isUserError e) (ioError e)
-- close callback
_ <- ebox `on` buttonPressEvent $ do
eb <- eventButton
case eb of
MiddleButton -> liftIO $ do
n <- notebookGetNPages (notebook myview)
when (n > 1) $ void $ destroyView myview
return True
_ -> return False
return myview return myview
-- |Constructs the initial MyView object with a few dummy models. -- |Constructs the initial MyView object with a few dummy models.
-- It also initializes the callbacks. -- It also initializes the callbacks.
createMyView :: MyGUI createMyView :: MyGUI
-> Notebook
-> IO FMView -> IO FMView
-> IO MyView -> IO MyView
createMyView mygui nb iofmv = do createMyView mygui iofmv = do
inotify <- newEmptyMVar inotify <- newEmptyMVar
history <- newEmptyMVar history <- newTVarIO ([],[])
builder <- builderNew builder <- builderNew
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml" builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
@ -160,13 +113,34 @@ createMyView mygui nb iofmv = do
urlBar <- builderGetObject builder castToEntry urlBar <- builderGetObject builder castToEntry
"urlBar" "urlBar"
rcMenu <- builderGetObject builder castToMenu
backViewB <- builderGetObject builder castToButton "rcMenu"
"backViewB" rcFileOpen <- builderGetObject builder castToImageMenuItem
"rcFileOpen"
rcFileExecute <- builderGetObject builder castToImageMenuItem
"rcFileExecute"
rcFileNewRegFile <- builderGetObject builder castToImageMenuItem
"rcFileNewRegFile"
rcFileNewDir <- builderGetObject builder castToImageMenuItem
"rcFileNewDir"
rcFileCut <- builderGetObject builder castToImageMenuItem
"rcFileCut"
rcFileCopy <- builderGetObject builder castToImageMenuItem
"rcFileCopy"
rcFileRename <- builderGetObject builder castToImageMenuItem
"rcFileRename"
rcFilePaste <- builderGetObject builder castToImageMenuItem
"rcFilePaste"
rcFileDelete <- builderGetObject builder castToImageMenuItem
"rcFileDelete"
rcFileProperty <- builderGetObject builder castToImageMenuItem
"rcFileProperty"
rcFileIconView <- builderGetObject builder castToImageMenuItem
"rcFileIconView"
rcFileTreeView <- builderGetObject builder castToImageMenuItem
"rcFileTreeView"
upViewB <- builderGetObject builder castToButton upViewB <- builderGetObject builder castToButton
"upViewB" "upViewB"
forwardViewB <- builderGetObject builder castToButton
"forwardViewB"
homeViewB <- builderGetObject builder castToButton homeViewB <- builderGetObject builder castToButton
"homeViewB" "homeViewB"
refreshViewB <- builderGetObject builder castToButton refreshViewB <- builderGetObject builder castToButton
@ -176,7 +150,7 @@ createMyView mygui nb iofmv = do
viewBox <- builderGetObject builder castToBox viewBox <- builderGetObject builder castToBox
"viewBox" "viewBox"
let notebook = nb let rcmenu = MkRightClickMenu {..}
let myview = MkMyView {..} let myview = MkMyView {..}
-- set the bindings -- set the bindings
@ -197,38 +171,37 @@ switchView :: MyGUI -> MyView -> IO FMView -> IO ()
switchView mygui myview iofmv = do switchView mygui myview iofmv = do
cwd <- getCurrentDir myview cwd <- getCurrentDir myview
let nb = notebook myview oldpage <- destroyView mygui myview
oldpage <- destroyView myview
-- create new view and tab page where the previous one was -- create new view and tab page where the previous one was
nview <- newTab mygui nb iofmv cwd oldpage nview <- createMyView mygui iofmv
newpage <- notebookInsertPage (notebook mygui) (viewBox nview)
(maybe (P.fromAbs $ path cwd) P.fromRel
$ P.basename . path $ cwd) oldpage
notebookSetCurrentPage (notebook mygui) newpage
page <- fromJust <$> notebookPageNum nb (viewBox nview) refreshView' mygui nview cwd
notebookSetCurrentPage nb page
refreshView mygui nview cwd
-- |Destroys the given view by disconnecting the watcher -- |Destroys the current view by disconnecting the watcher
-- and destroying the active FMView container. -- and destroying the active FMView container.
-- --
-- Everything that needs to be done in order to forget about a -- Everything that needs to be done in order to forget about a
-- view needs to be done here. -- view needs to be done here.
-- --
-- Returns the page in the tab list this view corresponds to. -- Returns the page in the tab list this view corresponds to.
destroyView :: MyView -> IO Int destroyView :: MyGUI -> MyView -> IO Int
destroyView myview = do destroyView mygui myview = do
-- disconnect watcher -- disconnect watcher
mi <- tryTakeMVar (inotify myview) mi <- tryTakeMVar (inotify myview)
for_ mi $ \i -> killINotify i for_ mi $ \i -> killINotify i
page <- fromJust <$> notebookPageNum (notebook myview) (viewBox myview) page <- notebookGetCurrentPage (notebook mygui)
-- destroy old view and tab page -- destroy old view and tab page
view' <- readTVarIO $ view myview view' <- readTVarIO $ view myview
widgetDestroy (fmViewToContainer view') widgetDestroy (fmViewToContainer view')
notebookRemovePage (notebook myview) page notebookRemovePage (notebook mygui) page
return page return page
@ -304,18 +277,46 @@ createTreeView = do
return $ FMTreeView treeView return $ FMTreeView treeView
-- |Re-reads the current directory or the given one and updates the View.
-- This is more or less a wrapper around `refreshView'`
--
-- If the third argument is Nothing, it tries to re-read the current directory.
-- If that fails, it reads "/" instead.
--
-- If the third argument is (Just path) it tries to read "path". If that
-- fails, it reads "/" instead.
refreshView :: MyGUI
-> MyView
-> Maybe (Path Abs)
-> IO ()
refreshView mygui myview mfp =
case mfp of
Just fp -> do
canopen <- canOpenDirectory fp
if canopen
then refreshView' mygui myview =<< readFile getFileInfo fp
else refreshView mygui myview =<< getAlternativeDir
Nothing -> refreshView mygui myview =<< getAlternativeDir
where
getAlternativeDir = do
ecd <- try (getCurrentDir myview) :: IO (Either SomeException
Item)
case ecd of
Right dir -> return (Just $ path dir)
Left _ -> return (P.parseAbs P.pathSeparator')
-- |Refreshes the View based on the given directory. -- |Refreshes the View based on the given directory.
-- --
-- Throws: -- If the directory is not a Dir or a Symlink pointing to a Dir, then
-- -- calls `refreshView` with the 3rd argument being Nothing.
-- - `userError` on inappropriate type refreshView' :: MyGUI
refreshView :: MyGUI
-> MyView -> MyView
-> Item -> Item
-> IO () -> IO ()
refreshView mygui myview SymLink { sdest = Just d@Dir{} } = refreshView' mygui myview SymLink { sdest = d@Dir{} } =
refreshView mygui myview d refreshView' mygui myview d
refreshView mygui myview item@Dir{} = do refreshView' mygui myview item@Dir{} = do
newRawModel <- fileListStore item myview newRawModel <- fileListStore item myview
writeTVarIO (rawModel myview) newRawModel writeTVarIO (rawModel myview) newRawModel
@ -330,6 +331,12 @@ refreshView mygui myview item@Dir{} = do
constructView mygui myview constructView mygui myview
-- set notebook tab label
page <- notebookGetCurrentPage (notebook mygui)
child <- fromJust <$> notebookGetNthPage (notebook mygui) page
notebookSetTabLabelText (notebook mygui) child
(maybe (P.fromAbs $ path item) P.fromRel $ P.basename . path $ item)
-- reselect selected items -- reselect selected items
-- TODO: not implemented for icon view yet -- TODO: not implemented for icon view yet
case view' of case view' of
@ -338,7 +345,8 @@ refreshView mygui myview item@Dir{} = do
ntps <- mapM treeRowReferenceGetPath trs ntps <- mapM treeRowReferenceGetPath trs
mapM_ (treeSelectionSelectPath tvs) ntps mapM_ (treeSelectionSelectPath tvs) ntps
_ -> return () _ -> return ()
refreshView _ _ _ = ioError $ userError "Inappropriate type!" refreshView' mygui myview Failed{} = refreshView mygui myview Nothing
refreshView' _ _ _ = return ()
-- |Constructs the visible View with the current underlying mutable models, -- |Constructs the visible View with the current underlying mutable models,
@ -363,14 +371,14 @@ constructView mygui myview = do
dirtreePix FileLike{} = filePix dirtreePix FileLike{} = filePix
dirtreePix DirSym{} = folderSymPix dirtreePix DirSym{} = folderSymPix
dirtreePix FileLikeSym{} = fileSymPix dirtreePix FileLikeSym{} = fileSymPix
dirtreePix Failed{} = errorPix
dirtreePix BrokenSymlink{} = errorPix dirtreePix BrokenSymlink{} = errorPix
dirtreePix _ = errorPix dirtreePix _ = errorPix
view' <- readTVarIO $ view myview view' <- readTVarIO $ view myview
cdir <- getCurrentDir myview cdirp <- path <$> getCurrentDir myview
let cdirp = path cdir
-- update urlBar -- update urlBar
entrySetText (urlBar myview) (P.fromAbs cdirp) entrySetText (urlBar myview) (P.fromAbs cdirp)
@ -385,7 +393,7 @@ constructView mygui myview = do
item <- treeModelGetRow rawModel' iter >>= (P.basename . path) item <- treeModelGetRow rawModel' iter >>= (P.basename . path)
if hidden if hidden
then return True then return True
else return . not . hiddenFile . P.fromRel $ item else return $ not . P.hiddenFile $ item
-- sorting -- sorting
sortedModel' <- treeModelSortNewWithModel filteredModel' sortedModel' <- treeModelSortNewWithModel filteredModel'
@ -411,7 +419,7 @@ constructView mygui myview = do
-- update model of view -- update model of view
case view' of case view' of
FMTreeView treeView -> do FMTreeView treeView -> do
treeViewSetModel treeView (Just sortedModel') treeViewSetModel treeView sortedModel'
treeViewSetRubberBanding treeView True treeViewSetRubberBanding treeView True
FMIconView iconView -> do FMIconView iconView -> do
iconViewSetModel iconView (Just sortedModel') iconViewSetModel iconView (Just sortedModel')
@ -428,7 +436,7 @@ constructView mygui myview = do
newi newi
[Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf] [Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
(P.fromAbs cdirp) (P.fromAbs cdirp)
(\_ -> postGUIAsync $ refreshView mygui myview cdir) (\_ -> postGUIAsync $ refreshView mygui myview (Just $ cdirp))
putMVar (inotify myview) newi putMVar (inotify myview) newi
return () return ()

112
src/HSFM/GUI/Gtk/Plugins.hs
View File

@ -1,112 +0,0 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
module HSFM.GUI.Gtk.Plugins where
import Graphics.UI.Gtk
import HPath
import HSFM.FileSystem.FileType
import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Settings
import HSFM.GUI.Gtk.Utils
import HSFM.Settings
import Control.Monad
(
forM
, forM_
, void
)
import System.Posix.Process.ByteString
(
executeFile
, forkProcess
)
import Data.ByteString.UTF8
(
fromString
)
import qualified Data.ByteString as BS
---------------
--[ Plugins ]--
---------------
---- Global settings ----
-- |Where to start inserting plugins.
insertPos :: Int
insertPos = 4
-- |A list of plugins to add to the right-click menu at position
-- `insertPos`.
--
-- The left part of the triple is a function that returns the menuitem.
-- The middle part of the triple is a filter function that
-- decides whether the item is shown.
-- The right part of the triple is the callback, which is invoked
-- when the menu item is clicked.
--
-- Plugins are added in order of this list.
myplugins :: [(IO MenuItem
,[Item] -> MyGUI -> MyView -> IO Bool
,[Item] -> MyGUI -> MyView -> IO ())
]
myplugins = [(diffItem, diffFilter, diffCallback)
]
---- The plugins ----
diffItem :: IO MenuItem
diffItem = menuItemNewWithLabel "diff"
diffFilter :: [Item] -> MyGUI -> MyView -> IO Bool
diffFilter items _ _
| length items > 1 = return $ and $ fmap isFileC items
| otherwise = return False
diffCallback :: [Item] -> MyGUI -> MyView -> IO ()
diffCallback items _ _ = void $
forkProcess $
executeFile
(fromString "meld")
True
([fromString "--diff"] ++ fmap (fromAbs . path) items)
Nothing

128
src/HSFM/GUI/Gtk/Settings.hs
View File

@ -1,128 +0,0 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# LANGUAGE PatternSynonyms #-}
module HSFM.GUI.Gtk.Settings where
import Graphics.UI.Gtk
--------------------
--[ GUI Settings ]--
--------------------
---- Hotkey settings ----
pattern QuitModifier :: [Modifier]
pattern QuitModifier <- [Control]
pattern QuitKey :: String
pattern QuitKey <- "q"
pattern ShowHiddenModifier :: [Modifier]
pattern ShowHiddenModifier <- [Control]
pattern ShowHiddenKey :: String
pattern ShowHiddenKey <- "h"
pattern UpDirModifier :: [Modifier]
pattern UpDirModifier <- [Alt]
pattern UpDirKey :: String
pattern UpDirKey <- "Up"
pattern HistoryBackModifier :: [Modifier]
pattern HistoryBackModifier <- [Alt]
pattern HistoryBackKey :: String
pattern HistoryBackKey <- "Left"
pattern HistoryForwardModifier :: [Modifier]
pattern HistoryForwardModifier <- [Alt]
pattern HistoryForwardKey :: String
pattern HistoryForwardKey <- "Right"
pattern DeleteModifier :: [Modifier]
pattern DeleteModifier <- []
pattern DeleteKey :: String
pattern DeleteKey <- "Delete"
pattern OpenModifier :: [Modifier]
pattern OpenModifier <- []
pattern OpenKey :: String
pattern OpenKey <- "Return"
pattern CopyModifier :: [Modifier]
pattern CopyModifier <- [Control]
pattern CopyKey :: String
pattern CopyKey <- "c"
pattern MoveModifier :: [Modifier]
pattern MoveModifier <- [Control]
pattern MoveKey :: String
pattern MoveKey <- "x"
pattern PasteModifier :: [Modifier]
pattern PasteModifier <- [Control]
pattern PasteKey :: String
pattern PasteKey <- "v"
pattern NewTabModifier :: [Modifier]
pattern NewTabModifier <- [Control]
pattern NewTabKey :: String
pattern NewTabKey <- "t"
pattern CloseTabModifier :: [Modifier]
pattern CloseTabModifier <- [Control]
pattern CloseTabKey :: String
pattern CloseTabKey <- "w"
pattern OpenTerminalModifier :: [Modifier]
pattern OpenTerminalModifier <- []
pattern OpenTerminalKey :: String
pattern OpenTerminalKey <- "F4"

16
src/HSFM/GUI/Gtk/Utils.hs
View File

@ -78,8 +78,8 @@ withItems :: MyGUI
-> ( [Item] -> ( [Item]
-> MyGUI -> MyGUI
-> MyView -> MyView
-> IO a) -- ^ action to carry out -> IO ()) -- ^ action to carry out
-> IO a -> IO ()
withItems mygui myview io = do withItems mygui myview io = do
items <- getSelectedItems mygui myview items <- getSelectedItems mygui myview
io items mygui myview io items mygui myview
@ -152,3 +152,15 @@ rawPathToItem myview tp = do
miter <- rawPathToIter myview tp miter <- rawPathToIter myview tp
forM miter $ \iter -> treeModelGetRow rawModel' iter forM miter $ \iter -> treeModelGetRow rawModel' iter
-- |Makes sure the list is max 5. This is probably not very efficient
-- but we don't care, since it's a small list anyway.
addHistory :: Eq a => a -> [a] -> [a]
addHistory i [] = [i]
addHistory i xs@(x:_)
| i == x = xs
| length xs == maxLength = i : take (maxLength - 1) xs
| otherwise = i : xs
where
maxLength = 10

61
src/HSFM/History.hs
View File

@ -1,61 +0,0 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.History where
import HPath
(
Abs
, Path
)
-- |Browsing history. For `forwardHistory` and `backwardsHistory`
-- the first item is the most recent one.
data BrowsingHistory = BrowsingHistory {
backwardsHistory :: [Path Abs]
, currentDir :: Path Abs
, forwardHistory :: [Path Abs]
, maxSize :: Int
}
-- |This is meant to be called after e.g. a new path is entered
-- (not navigated to via the history) and the history needs updating.
historyNewPath :: Path Abs -> BrowsingHistory -> BrowsingHistory
historyNewPath p (BrowsingHistory b cd _ s) =
BrowsingHistory (take s $ cd:b) p [] s
-- |Go back one step in the history.
historyBack :: BrowsingHistory -> BrowsingHistory
historyBack bh@(BrowsingHistory [] _ _ _) = bh
historyBack (BrowsingHistory (b:bs) cd fs s) =
BrowsingHistory bs b (take s $ cd:fs) s
-- |Go forward one step in the history.
historyForward :: BrowsingHistory -> BrowsingHistory
historyForward bh@(BrowsingHistory _ _ [] _) = bh
historyForward (BrowsingHistory bs cd (f:fs) s) =
BrowsingHistory (take s $ cd:bs) f fs s

67
src/HSFM/Settings.hs
View File

@ -1,67 +0,0 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.Settings where
import Data.ByteString
(
ByteString
)
import qualified Data.ByteString.UTF8 as BU
import Data.Maybe
import System.Posix.Env.ByteString
import System.Posix.Process.ByteString
-----------------------
--[ Common Settings ]--
-----------------------
---- Command settings ----
-- |The terminal command. This should call `executeFile` in the end
-- with the appropriate arguments.
terminalCommand :: ByteString -- ^ current directory of the FM
-> IO a
terminalCommand cwd =
executeFile -- executes the given command
(BU.fromString "sakura") -- the terminal command
True -- whether to search PATH
[BU.fromString "-d", cwd] -- arguments for the command
Nothing -- optional custom environment: `Just [(String, String)]`
-- |The home directory. If you want to set it explicitly, you might
-- want to do:
--
-- @
-- home = return "\/home\/wurst"
-- @
home :: IO ByteString
home = fromMaybe <$> return (BU.fromString "/") <*> getEnv (BU.fromString "HOME")

16
src/HSFM/Utils/IO.hs
View File

@ -33,6 +33,11 @@ import Control.Concurrent.STM.TVar
, modifyTVar , modifyTVar
, TVar , TVar
) )
import Control.Monad
(
when
, unless
)
-- |Atomically write a TVar. -- |Atomically write a TVar.
@ -44,3 +49,14 @@ writeTVarIO tvar val = atomically $ writeTVar tvar val
modifyTVarIO :: TVar a -> (a -> a) -> IO () modifyTVarIO :: TVar a -> (a -> a) -> IO ()
modifyTVarIO tvar f = atomically $ modifyTVar tvar f modifyTVarIO tvar f = atomically $ modifyTVar tvar f
-- |If the value of the first argument is True, then execute the action
-- provided in the second argument, otherwise do nothing.
whenM :: Monad m => m Bool -> m () -> m ()
whenM mb a = mb >>= (`when` a)
-- |If the value of the first argument is False, then execute the action
-- provided in the second argument, otherwise do nothing.
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM mb a = mb >>= (`unless` a)

4
src/HSFM/Utils/MyPrelude.hs
View File

@ -19,6 +19,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
module HSFM.Utils.MyPrelude where module HSFM.Utils.MyPrelude where
import Data.Default
import Data.List import Data.List
@ -30,3 +31,6 @@ listIndices :: [a] -> [Int]
listIndices = findIndices (const True) listIndices = findIndices (const True)
-- |A `maybe` flavor using the `Default` class.
maybeD :: (Default b) => (a -> b) -> Maybe a -> b
maybeD = maybe def

110
test/FileSystem/FileOperations/CopyDirRecursiveOverwriteSpec.hs Normal file
View File

@ -0,0 +1,110 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.CopyDirRecursiveOverwriteSpec where
import Test.Hspec
import HSFM.FileSystem.Errors
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import System.Exit
import System.Process
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/copyDirRecursiveOverwriteSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.copyDirRecursiveOverwrite" $ do
-- successes --
it "copyDirRecursiveOverwrite, all fine" $ do
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
(specDir `ba` "outputDir")
removeDirIfExists $ specDir `ba` "outputDir"
it "copyDirRecursiveOverwrite, all fine and compare" $ do
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
(specDir `ba` "outputDir")
(system $ "diff -r --no-dereference "
++ specDir' ++ "inputDir" ++ " "
++ specDir' ++ "outputDir")
`shouldReturn` ExitSuccess
removeDirIfExists $ specDir `ba` "outputDir"
it "copyDirRecursiveOverwrite, destination dir already exists" $
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
(specDir `ba` "alreadyExistsD")
-- posix failures --
it "copyDirRecursiveOverwrite, source directory does not exist" $
copyDirRecursiveOverwrite' (specDir `ba` "doesNotExist")
(specDir `ba` "outputDir")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "copyDirRecursiveOverwrite, no write permission on output dir" $
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
(specDir `ba` "noWritePerm/foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyDirRecursiveOverwrite, cannot open output dir" $
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
(specDir `ba` "noPerms/foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyDirRecursiveOverwrite, cannot open source dir" $
copyDirRecursiveOverwrite' (specDir `ba` "noPerms/inputDir")
(specDir `ba` "foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyDirRecursiveOverwrite, destination already exists and is a file" $
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
(specDir `ba` "alreadyExists")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "copyDirRecursiveOverwrite, wrong input (regular file)" $
copyDirRecursiveOverwrite' (specDir `ba` "wrongInput")
(specDir `ba` "outputDir")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "copyDirRecursiveOverwrite, wrong input (symlink to directory)" $
copyDirRecursiveOverwrite' (specDir `ba` "wrongInputSymL")
(specDir `ba` "outputDir")
`shouldThrow`
(\e -> ioeGetErrorType e == InvalidArgument)
-- custom failures
it "copyDirRecursiveOverwrite, destination in source" $
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
(specDir `ba` "inputDir/foo")
`shouldThrow`
isDestinationInSource
it "copyDirRecursiveOverwrite, destination and source same directory" $
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
(specDir `ba` "inputDir")
`shouldThrow`
isSameFile

112
test/FileSystem/FileOperations/CopyDirRecursiveSpec.hs Normal file
View File

@ -0,0 +1,112 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.CopyDirRecursiveSpec where
import Test.Hspec
import HSFM.FileSystem.Errors
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import System.Exit
import System.Process
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/copyDirRecursiveSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.copyDirRecursive" $ do
-- successes --
it "copyDirRecursive, all fine" $ do
copyDirRecursive' (specDir `ba` "inputDir")
(specDir `ba` "outputDir")
removeDirIfExists (specDir `ba` "outputDir")
it "copyDirRecursive, all fine and compare" $ do
copyDirRecursive' (specDir `ba` "inputDir")
(specDir `ba` "outputDir")
(system $ "diff -r --no-dereference "
++ specDir' ++ "inputDir" ++ " "
++ specDir' ++ "outputDir")
`shouldReturn` ExitSuccess
removeDirIfExists (specDir `ba` "outputDir")
-- posix failures --
it "copyDirRecursive, source directory does not exist" $
copyDirRecursive' (specDir `ba` "doesNotExist")
(specDir `ba` "outputDir")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "copyDirRecursive, no write permission on output dir" $
copyDirRecursive' (specDir `ba` "inputDir")
(specDir `ba` "noWritePerm/foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyDirRecursive, cannot open output dir" $
copyDirRecursive' (specDir `ba` "inputDir")
(specDir `ba` "noPerms/foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyDirRecursive, cannot open source dir" $
copyDirRecursive' (specDir `ba` "noPerms/inputDir")
(specDir `ba` "foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyDirRecursive, destination dir already exists" $
copyDirRecursive' (specDir `ba` "inputDir")
(specDir `ba` "alreadyExistsD")
`shouldThrow`
(\e -> ioeGetErrorType e == AlreadyExists)
it "copyDirRecursive, destination already exists and is a file" $
copyDirRecursive' (specDir `ba` "inputDir")
(specDir `ba` "alreadyExists")
`shouldThrow`
(\e -> ioeGetErrorType e == AlreadyExists)
it "copyDirRecursive, wrong input (regular file)" $
copyDirRecursive' (specDir `ba` "wrongInput")
(specDir `ba` "outputDir")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "copyDirRecursive, wrong input (symlink to directory)" $
copyDirRecursive' (specDir `ba` "wrongInputSymL")
(specDir `ba` "outputDir")
`shouldThrow`
(\e -> ioeGetErrorType e == InvalidArgument)
-- custom failures
it "copyDirRecursive, destination in source" $
copyDirRecursive' (specDir `ba` "inputDir")
(specDir `ba` "inputDir/foo")
`shouldThrow`
isDestinationInSource
it "copyDirRecursive, destination and source same directory" $
copyDirRecursive' (specDir `ba` "inputDir")
(specDir `ba` "inputDir")
`shouldThrow`
isSameFile

109
test/FileSystem/FileOperations/CopyFileOverwriteSpec.hs Normal file
View File

@ -0,0 +1,109 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.CopyFileOverwriteSpec where
import Test.Hspec
import HSFM.FileSystem.Errors
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import System.Exit
import System.Process
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/copyFileOverwriteSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.copyFileOverwrite" $ do
-- successes --
it "copyFileOverwrite, everything clear" $ do
copyFileOverwrite' (specDir `ba` "inputFile")
(specDir `ba` "outputFile")
removeFileIfExists (specDir `ba` "outputFile")
it "copyFileOverwrite, output file already exists, all clear" $ do
copyFile' (specDir `ba` "alreadyExists") (specDir `ba` "alreadyExists.bak")
copyFileOverwrite' (specDir `ba` "inputFile")
(specDir `ba` "alreadyExists")
(system $ "cmp -s " ++ specDir' ++ "inputFile" ++ " "
++ specDir' ++ "alreadyExists")
`shouldReturn` ExitSuccess
removeFileIfExists (specDir `ba` "alreadyExists")
copyFile' (specDir `ba` "alreadyExists.bak") (specDir `ba` "alreadyExists")
removeFileIfExists (specDir `ba` "alreadyExists.bak")
it "copyFileOverwrite, and compare" $ do
copyFileOverwrite' (specDir `ba` "inputFile")
(specDir `ba` "outputFile")
(system $ "cmp -s " ++ specDir' ++ "inputFile" ++ " "
++ specDir' ++ "outputFile")
`shouldReturn` ExitSuccess
removeFileIfExists (specDir `ba` "outputFile")
-- posix failures --
it "copyFileOverwrite, input file does not exist" $
copyFileOverwrite' (specDir `ba` "noSuchFile")
(specDir `ba` "outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "copyFileOverwrite, no permission to write to output directory" $
copyFileOverwrite' (specDir `ba` "inputFile")
(specDir `ba` "outputDirNoWrite/outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyFileOverwrite, cannot open output directory" $
copyFileOverwrite' (specDir `ba` "inputFile")
(specDir `ba` "noPerms/outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyFileOverwrite, cannot open source directory" $
copyFileOverwrite' (specDir `ba` "noPerms/inputFile")
(specDir `ba` "outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyFileOverwrite, wrong input type (symlink)" $
copyFileOverwrite' (specDir `ba` "inputFileSymL")
(specDir `ba` "outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == InvalidArgument)
it "copyFileOverwrite, wrong input type (directory)" $
copyFileOverwrite' (specDir `ba` "wrongInput")
(specDir `ba` "outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "copyFileOverwrite, output file already exists and is a dir" $
copyFileOverwrite' (specDir `ba` "inputFile")
(specDir `ba` "alreadyExistsD")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
-- custom failures --
it "copyFileOverwrite, output and input are same file" $
copyFileOverwrite' (specDir `ba` "inputFile")
(specDir `ba` "inputFile")
`shouldThrow` isSameFile

105
test/FileSystem/FileOperations/CopyFileSpec.hs Normal file
View File

@ -0,0 +1,105 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.CopyFileSpec where
import Test.Hspec
import HSFM.FileSystem.Errors
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import System.Exit
import System.Process
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/copyFileSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.copyFile" $ do
-- successes --
it "copyFile, everything clear" $ do
copyFile' (specDir `ba` "inputFile")
(specDir `ba` "outputFile")
removeFileIfExists (specDir `ba` "outputFile")
it "copyFile, and compare" $ do
copyFile' (specDir `ba` "inputFile")
(specDir `ba` "outputFile")
(system $ "cmp -s " ++ specDir' ++ "inputFile" ++ " "
++ specDir' ++ "outputFile")
`shouldReturn` ExitSuccess
removeFileIfExists (specDir `ba` "outputFile")
-- posix failures --
it "copyFile, input file does not exist" $
copyFile' (specDir `ba` "noSuchFile")
(specDir `ba` "outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "copyFile, no permission to write to output directory" $
copyFile' (specDir `ba` "inputFile")
(specDir `ba` "outputDirNoWrite/outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyFile, cannot open output directory" $
copyFile' (specDir `ba` "inputFile")
(specDir `ba` "noPerms/outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyFile, cannot open source directory" $
copyFile' (specDir `ba` "noPerms/inputFile")
(specDir `ba` "outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyFile, wrong input type (symlink)" $
copyFile' (specDir `ba` "inputFileSymL")
(specDir `ba` "outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == InvalidArgument)
it "copyFile, wrong input type (directory)" $
copyFile' (specDir `ba` "wrongInput")
(specDir `ba` "outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "copyFile, output file already exists" $
copyFile' (specDir `ba` "inputFile")
(specDir `ba` "alreadyExists")
`shouldThrow`
(\e -> ioeGetErrorType e == AlreadyExists)
it "copyFile, output file already exists and is a dir" $
copyFile' (specDir `ba` "inputFile")
(specDir `ba` "alreadyExistsD")
`shouldThrow`
(\e -> ioeGetErrorType e == AlreadyExists)
-- custom failures --
it "copyFile, output and input are same file" $
copyFile' (specDir `ba` "inputFile")
(specDir `ba` "inputFile")
`shouldThrow`
isSameFile

54
test/FileSystem/FileOperations/CreateDirSpec.hs Normal file
View File

@ -0,0 +1,54 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.CreateDirSpec where
import Test.Hspec
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/createDirSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.createDir" $ do
-- successes --
it "createDir, all fine" $ do
createDir' (specDir `ba` "newDir")
removeDirIfExists (specDir `ba` "newDir")
-- posix failures --
it "createDir, can't write to output directory" $
createDir' (specDir `ba` "noWritePerms/newDir")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "createDir, can't open output directory" $
createDir' (specDir `ba` "noPerms/newDir")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "createDir, destination directory already exists" $
createDir' (specDir `ba` "alreadyExists")
`shouldThrow`
(\e -> ioeGetErrorType e == AlreadyExists)

54
test/FileSystem/FileOperations/CreateRegularFileSpec.hs Normal file
View File

@ -0,0 +1,54 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.CreateRegularFileSpec where
import Test.Hspec
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/createRegularFileSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.createRegularFile" $ do
-- successes --
it "createRegularFile, all fine" $ do
createRegularFile' (specDir `ba` "newDir")
removeFileIfExists (specDir `ba` "newDir")
-- posix failures --
it "createRegularFile, can't write to destination directory" $
createRegularFile' (specDir `ba` "noWritePerms/newDir")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "createRegularFile, can't write to destination directory" $
createRegularFile' (specDir `ba` "noPerms/newDir")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "createRegularFile, destination file already exists" $
createRegularFile' (specDir `ba` "alreadyExists")
`shouldThrow`
(\e -> ioeGetErrorType e == AlreadyExists)

97
test/FileSystem/FileOperations/DeleteDirRecursiveSpec.hs Normal file
View File

@ -0,0 +1,97 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.DeleteDirRecursiveSpec where
import Test.Hspec
import System.IO.Error
(
ioeGetErrorType
)
import System.Posix.Files.ByteString
(
getSymbolicLinkStatus
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/deleteDirRecursiveSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.deleteDirRecursive" $ do
-- successes --
it "deleteDirRecursive, empty directory, all fine" $ do
createDir' (specDir `ba` "testDir")
deleteDirRecursive' (specDir `ba` "testDir")
getSymbolicLinkStatus (specDir `ba` "testDir")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "deleteDirRecursive, empty directory with null permissions, all fine" $ do
createDir' (specDir `ba` "noPerms/testDir")
noPerms (specDir `ba` "noPerms/testDir")
deleteDirRecursive' (specDir `ba` "noPerms/testDir")
it "deleteDirRecursive, non-empty directory, all fine" $ do
createDir' (specDir `ba` "nonEmpty")
createDir' (specDir `ba` "nonEmpty/dir1")
createDir' (specDir `ba` "nonEmpty/dir2")
createDir' (specDir `ba` "nonEmpty/dir2/dir3")
createRegularFile' (specDir `ba` "nonEmpty/file1")
createRegularFile' (specDir `ba` "nonEmpty/dir1/file2")
deleteDirRecursive' (specDir `ba` "nonEmpty")
getSymbolicLinkStatus (specDir `ba` "nonEmpty")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
-- posix failures --
it "deleteDirRecursive, can't open parent directory" $ do
createDir' (specDir `ba` "noPerms/foo")
noPerms (specDir `ba` "noPerms")
(deleteDirRecursive' (specDir `ba` "noPerms/foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied))
>> normalDirPerms (specDir `ba` "noPerms")
>> deleteDir' (specDir `ba` "noPerms/foo")
it "deleteDirRecursive, can't write to parent directory" $ do
createDir' (specDir `ba` "noWritable/foo")
noWritableDirPerms (specDir `ba` "noWritable")
(deleteDirRecursive' (specDir `ba` "noWritable/foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied))
normalDirPerms (specDir `ba` "noWritable")
deleteDir' (specDir `ba` "noWritable/foo")
it "deleteDirRecursive, wrong file type (symlink to directory)" $
deleteDirRecursive' (specDir `ba` "dirSym")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "deleteDirRecursive, wrong file type (regular file)" $
deleteDirRecursive' (specDir `ba` "file")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "deleteDirRecursive, directory does not exist" $
deleteDirRecursive' (specDir `ba` "doesNotExist")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)

94
test/FileSystem/FileOperations/DeleteDirSpec.hs Normal file
View File

@ -0,0 +1,94 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.DeleteDirSpec where
import Test.Hspec
import System.IO.Error
(
ioeGetErrorType
)
import System.Posix.Files.ByteString
(
getSymbolicLinkStatus
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/deleteDirSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.deleteDir" $ do
-- successes --
it "deleteDir, empty directory, all fine" $ do
createDir' (specDir `ba` "testDir")
deleteDir' (specDir `ba` "testDir")
getSymbolicLinkStatus (specDir `ba` "testDir")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "deleteDir, directory with null permissions, all fine" $ do
createDir' (specDir `ba` "noPerms/testDir")
noPerms (specDir `ba` "noPerms/testDir")
deleteDir' (specDir `ba` "noPerms/testDir")
getSymbolicLinkStatus (specDir `ba` "testDir")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
-- posix failures --
it "deleteDir, wrong file type (symlink to directory)" $
deleteDir' (specDir `ba` "dirSym")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "deleteDir, wrong file type (regular file)" $
deleteDir' (specDir `ba` "file")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "deleteDir, directory does not exist" $
deleteDir' (specDir `ba` "doesNotExist")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "deleteDir, directory not empty" $
deleteDir' (specDir `ba` "dir")
`shouldThrow`
(\e -> ioeGetErrorType e == UnsatisfiedConstraints)
it "deleteDir, can't open parent directory" $ do
createDir' (specDir `ba` "noPerms/foo")
noPerms (specDir `ba` "noPerms")
(deleteDir' (specDir `ba` "noPerms/foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied))
>> normalDirPerms (specDir `ba` "noPerms")
>> deleteDir' (specDir `ba` "noPerms/foo")
it "deleteDir, can't write to parent directory, still fine" $ do
createDir' (specDir `ba` "noWritable/foo")
noWritableDirPerms (specDir `ba` "noWritable")
(deleteDir' (specDir `ba` "noWritable/foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied))
normalDirPerms (specDir `ba` "noWritable")
deleteDir' (specDir `ba` "noWritable/foo")

69
test/FileSystem/FileOperations/DeleteFileSpec.hs Normal file
View File

@ -0,0 +1,69 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.DeleteFileSpec where
import Test.Hspec
import System.IO.Error
(
ioeGetErrorType
)
import System.Posix.Files.ByteString
(
getSymbolicLinkStatus
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/deleteFileSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.deleteFile" $ do
-- successes --
it "deleteFile, regular file, all fine" $ do
createRegularFile' (specDir `ba` "testFile")
deleteFile' (specDir `ba` "testFile")
getSymbolicLinkStatus (specDir `ba` "testFile")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "deleteFile, symlink, all fine" $ do
recreateSymlink' (specDir `ba` "syml")
(specDir `ba` "testFile")
deleteFile' (specDir `ba` "testFile")
getSymbolicLinkStatus (specDir `ba` "testFile")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
-- posix failures --
it "deleteFile, wrong file type (directory)" $
deleteFile' (specDir `ba` "dir")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "deleteFile, file does not exist" $
deleteFile' (specDir `ba` "doesNotExist")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "deleteFile, can't read directory" $
deleteFile' (specDir `ba` "noPerms/blah")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)

88
test/FileSystem/FileOperations/GetDirsFilesSpec.hs Normal file
View File

@ -0,0 +1,88 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.GetDirsFilesSpec where
import Data.List
(
sort
)
import Data.Maybe
(
fromJust
)
import qualified HPath as P
import Test.Hspec
import System.IO.Error
(
ioeGetErrorType
)
import System.Posix.Env.ByteString
(
getEnv
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/getDirsFilesSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.getDirsFiles" $ do
-- successes --
it "getDirsFiles, all fine" $ do
pwd <- fromJust <$> getEnv "PWD" >>= P.parseAbs
expectedFiles <- mapM P.parseRel [(specDir `ba ` ".hidden")
,(specDir `ba ` "Lala")
,(specDir `ba ` "dir")
,(specDir `ba ` "dirsym")
,(specDir `ba ` "file")
,(specDir `ba ` "noPerms")
,(specDir `ba ` "syml")]
(fmap sort $ getDirsFiles' specDir)
`shouldReturn` fmap (pwd P.</>) expectedFiles
-- posix failures --
it "getDirsFiles, nonexistent directory" $
getDirsFiles' (specDir `ba ` "nothingHere")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "getDirsFiles, wrong file type (file)" $
getDirsFiles' (specDir `ba ` "file")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "getDirsFiles, wrong file type (symlink to file)" $
getDirsFiles' (specDir `ba ` "syml")
`shouldThrow`
(\e -> ioeGetErrorType e == InvalidArgument)
it "getDirsFiles, wrong file type (symlink to dir)" $
getDirsFiles' (specDir `ba ` "dirsym")
`shouldThrow`
(\e -> ioeGetErrorType e == InvalidArgument)
it "getDirsFiles, can't open directory" $
getDirsFiles' (specDir `ba ` "noPerms")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)

70
test/FileSystem/FileOperations/GetFileTypeSpec.hs Normal file
View File

@ -0,0 +1,70 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.GetFileTypeSpec where
import HSFM.FileSystem.FileOperations
import Test.Hspec
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/getFileTypeSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.getFileType" $ do
-- successes --
it "getFileType, regular file" $
getFileType' (specDir `ba` "regularfile")
`shouldReturn` RegularFile
it "getFileType, directory" $
getFileType' (specDir `ba` "directory")
`shouldReturn` Directory
it "getFileType, directory with null permissions" $
getFileType' (specDir `ba` "noPerms")
`shouldReturn` Directory
it "getFileType, symlink to file" $
getFileType' (specDir `ba` "symlink")
`shouldReturn` SymbolicLink
it "getFileType, symlink to directory" $
getFileType' (specDir `ba` "symlinkD")
`shouldReturn` SymbolicLink
it "getFileType, broken symlink" $
getFileType' (specDir `ba` "brokenSymlink")
`shouldReturn` SymbolicLink
-- posix failures --
it "getFileType, file does not exist" $
getFileType' (specDir `ba` "nothingHere")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "getFileType, can't open directory" $
getFileType' (specDir `ba` "noPerms/forz")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)

93
test/FileSystem/FileOperations/MoveFileOverwriteSpec.hs Normal file
View File

@ -0,0 +1,93 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.MoveFileOverwriteSpec where
import Test.Hspec
import HSFM.FileSystem.Errors
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/moveFileOverwriteSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.moveFileOverwrite" $ do
-- successes --
it "moveFileOverwrite, all fine" $
moveFileOverwrite' (specDir `ba` "myFile")
(specDir `ba` "movedFile")
it "moveFileOverwrite, all fine" $
moveFileOverwrite' (specDir `ba` "myFile")
(specDir `ba` "dir/movedFile")
it "moveFileOverwrite, all fine on symlink" $
moveFileOverwrite' (specDir `ba` "myFileL")
(specDir `ba` "movedFile")
it "moveFileOverwrite, all fine on directory" $
moveFileOverwrite' (specDir `ba` "dir")
(specDir `ba` "movedFile")
it "moveFileOverwrite, destination file already exists" $
moveFileOverwrite' (specDir `ba` "myFile")
(specDir `ba` "alreadyExists")
-- posix failures --
it "moveFileOverwrite, source file does not exist" $
moveFileOverwrite' (specDir `ba` "fileDoesNotExist")
(specDir `ba` "movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "moveFileOverwrite, can't write to destination directory" $
moveFileOverwrite' (specDir `ba` "myFile")
(specDir `ba` "noWritePerm/movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "moveFileOverwrite, can't open destination directory" $
moveFileOverwrite' (specDir `ba` "myFile")
(specDir `ba` "noPerms/movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "moveFileOverwrite, can't open source directory" $
moveFileOverwrite' (specDir `ba` "noPerms/myFile")
(specDir `ba` "movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
-- custom failures --
it "moveFileOverwrite, move from file to dir" $
moveFileOverwrite' (specDir `ba` "myFile")
(specDir `ba` "alreadyExistsD")
`shouldThrow`
isDirDoesExist
it "moveFileOverwrite, source and dest are same file" $
moveFileOverwrite' (specDir `ba` "myFile")
(specDir `ba` "myFile")
`shouldThrow`
isSameFile

95
test/FileSystem/FileOperations/MoveFileSpec.hs Normal file
View File

@ -0,0 +1,95 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.MoveFileSpec where
import Test.Hspec
import HSFM.FileSystem.Errors
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/moveFileSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.moveFile" $ do
-- successes --
it "moveFile, all fine" $
moveFile' (specDir `ba` "myFile")
(specDir `ba` "movedFile")
it "moveFile, all fine" $
moveFile' (specDir `ba` "myFile")
(specDir `ba` "dir/movedFile")
it "moveFile, all fine on symlink" $
moveFile' (specDir `ba` "myFileL")
(specDir `ba` "movedFile")
it "moveFile, all fine on directory" $
moveFile' (specDir `ba` "dir")
(specDir `ba` "movedFile")
-- posix failures --
it "moveFile, source file does not exist" $
moveFile' (specDir `ba` "fileDoesNotExist")
(specDir `ba` "movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "moveFile, can't write to destination directory" $
moveFile' (specDir `ba` "myFile")
(specDir `ba` "noWritePerm/movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "moveFile, can't open destination directory" $
moveFile' (specDir `ba` "myFile")
(specDir `ba` "noPerms/movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "moveFile, can't open source directory" $
moveFile' (specDir `ba` "noPerms/myFile")
(specDir `ba` "movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
-- custom failures --
it "moveFile, destination file already exists" $
moveFile' (specDir `ba` "myFile")
(specDir `ba` "alreadyExists")
`shouldThrow`
isFileDoesExist
it "moveFile, move from file to dir" $
moveFile' (specDir `ba` "myFile")
(specDir `ba` "alreadyExistsD")
`shouldThrow`
isDirDoesExist
it "moveFile, source and dest are same file" $
moveFile' (specDir `ba` "myFile")
(specDir `ba` "myFile")
`shouldThrow`
isSameFile

95
test/FileSystem/FileOperations/RecreateSymlinkSpec.hs Normal file
View File

@ -0,0 +1,95 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.RecreateSymlinkSpec where
import Test.Hspec
import HSFM.FileSystem.Errors
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/recreateSymlinkSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.recreateSymlink" $ do
-- successes --
it "recreateSymLink, all fine" $ do
recreateSymlink' (specDir `ba` "myFileL")
(specDir `ba` "movedFile")
removeFileIfExists (specDir `ba` "movedFile")
it "recreateSymLink, all fine" $ do
recreateSymlink' (specDir `ba` "myFileL")
(specDir `ba` "dir/movedFile")
removeFileIfExists (specDir `ba` "dir/movedFile")
-- posix failures --
it "recreateSymLink, wrong input type (file)" $
recreateSymlink' (specDir `ba` "myFile")
(specDir `ba` "movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == InvalidArgument)
it "recreateSymLink, wrong input type (directory)" $
recreateSymlink' (specDir `ba` "dir")
(specDir `ba` "movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == InvalidArgument)
it "recreateSymLink, can't write to destination directory" $
recreateSymlink' (specDir `ba` "myFileL")
(specDir `ba` "noWritePerm/movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "recreateSymLink, can't open destination directory" $
recreateSymlink' (specDir `ba` "myFileL")
(specDir `ba` "noPerms/movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "recreateSymLink, can't open source directory" $
recreateSymlink' (specDir `ba` "noPerms/myFileL")
(specDir `ba` "movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "recreateSymLink, destination file already exists" $
recreateSymlink' (specDir `ba` "myFileL")
(specDir `ba` "alreadyExists")
`shouldThrow`
(\e -> ioeGetErrorType e == AlreadyExists)
it "recreateSymLink, destination already exists and is a dir" $
recreateSymlink' (specDir `ba` "myFileL")
(specDir `ba` "alreadyExistsD")
`shouldThrow`
(\e -> ioeGetErrorType e == AlreadyExists)
-- custom failures --
it "recreateSymLink, source and destination are the same file" $
recreateSymlink' (specDir `ba` "myFileL")
(specDir `ba` "myFileL")
`shouldThrow`
isSameFile

95
test/FileSystem/FileOperations/RenameFileSpec.hs Normal file
View File

@ -0,0 +1,95 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.RenameFileSpec where
import Test.Hspec
import HSFM.FileSystem.Errors
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/renameFileSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.renameFile" $ do
-- successes --
it "renameFile, all fine" $
renameFile' (specDir `ba` "myFile")
(specDir `ba` "renamedFile")
it "renameFile, all fine" $
renameFile' (specDir `ba` "myFile")
(specDir `ba` "dir/renamedFile")
it "renameFile, all fine on symlink" $
renameFile' (specDir `ba` "myFileL")
(specDir `ba` "renamedFile")
it "renameFile, all fine on directory" $
renameFile' (specDir `ba` "dir")
(specDir `ba` "renamedFile")
-- posix failures --
it "renameFile, source file does not exist" $
renameFile' (specDir `ba` "fileDoesNotExist")
(specDir `ba` "renamedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "renameFile, can't write to output directory" $
renameFile' (specDir `ba` "myFile")
(specDir `ba` "noWritePerm/renamedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "renameFile, can't open output directory" $
renameFile' (specDir `ba` "myFile")
(specDir `ba` "noPerms/renamedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "renameFile, can't open source directory" $
renameFile' (specDir `ba` "noPerms/myFile")
(specDir `ba` "renamedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
-- custom failures --
it "renameFile, destination file already exists" $
renameFile' (specDir `ba` "myFile")
(specDir `ba` "alreadyExists")
`shouldThrow`
isFileDoesExist
it "renameFile, move from file to dir" $
renameFile' (specDir `ba` "myFile")
(specDir `ba` "alreadyExistsD")
`shouldThrow`
isDirDoesExist
it "renameFile, source and dest are same file" $
renameFile' (specDir `ba` "myFile")
(specDir `ba` "myFile")
`shouldThrow`
isSameFile

0
test/FileSystem/FileOperations/copyDirRecursiveOverwriteSpec/alreadyExists Executable file
View File

0
test/FileSystem/FileOperations/copyDirRecursiveOverwriteSpec/alreadyExistsD/.keep Normal file
View File

8
test/FileSystem/FileOperations/copyDirRecursiveOverwriteSpec/alreadyExistsD/bar/inputFile3 Normal file
View File

@ -0,0 +1,8 @@
dadasasddas
sda
!!1
sda
11

1
test/FileSystem/FileOperations/copyDirRecursiveOverwriteSpec/alreadyExistsD/foo/inputFile1 Normal file
View File

@ -0,0 +1 @@
dadasasddas

4
test/FileSystem/FileOperations/copyDirRecursiveOverwriteSpec/alreadyExistsD/inputFile2 Normal file
View File

@ -0,0 +1,4 @@
dadasasddas
das
sda
sda

8
test/FileSystem/FileOperations/copyDirRecursiveOverwriteSpec/inputDir/bar/inputFile3 Normal file
View File

@ -0,0 +1,8 @@
dadasasddas
sda
!!1
sda
11

1
test/FileSystem/FileOperations/copyDirRecursiveOverwriteSpec/inputDir/foo/inputFile1 Normal file
View File

@ -0,0 +1 @@
dadasasddas

4
test/FileSystem/FileOperations/copyDirRecursiveOverwriteSpec/inputDir/inputFile2 Normal file
View File

@ -0,0 +1,4 @@
dadasasddas
das
sda
sda

8
test/FileSystem/FileOperations/copyDirRecursiveOverwriteSpec/noPerms/inputDir/bar/inputFile3 Normal file
View File

@ -0,0 +1,8 @@
dadasasddas
sda
!!1
sda
11

1
test/FileSystem/FileOperations/copyDirRecursiveOverwriteSpec/noPerms/inputDir/foo/inputFile1 Normal file
View File

@ -0,0 +1 @@
dadasasddas

4
test/FileSystem/FileOperations/copyDirRecursiveOverwriteSpec/noPerms/inputDir/inputFile2 Normal file
View File

@ -0,0 +1,4 @@
dadasasddas
das
sda
sda

0
test/FileSystem/FileOperations/copyDirRecursiveOverwriteSpec/noWritePerm/.keep Normal file
View File

0
test/FileSystem/FileOperations/copyDirRecursiveOverwriteSpec/wrongInput Normal file
View File

1
test/FileSystem/FileOperations/copyDirRecursiveOverwriteSpec/wrongInputSymL Symbolic link
View File

@ -0,0 +1 @@
inputDir/

0
test/FileSystem/FileOperations/copyDirRecursiveSpec/alreadyExists Normal file
View File

0
test/FileSystem/FileOperations/copyDirRecursiveSpec/alreadyExistsD/.keep Normal file
View File

8
test/FileSystem/FileOperations/copyDirRecursiveSpec/inputDir/bar/inputFile3 Normal file
View File

@ -0,0 +1,8 @@
dadasasddas
sda
!!1
sda
11

1
test/FileSystem/FileOperations/copyDirRecursiveSpec/inputDir/foo/inputFile1 Normal file
View File

@ -0,0 +1 @@
dadasasddas

4
test/FileSystem/FileOperations/copyDirRecursiveSpec/inputDir/inputFile2 Normal file
View File

@ -0,0 +1,4 @@
dadasasddas
das
sda
sda

8
test/FileSystem/FileOperations/copyDirRecursiveSpec/noPerms/inputDir/bar/inputFile3 Normal file
View File

@ -0,0 +1,8 @@
dadasasddas
sda
!!1
sda
11

1
test/FileSystem/FileOperations/copyDirRecursiveSpec/noPerms/inputDir/foo/inputFile1 Normal file
View File

@ -0,0 +1 @@
dadasasddas

4
test/FileSystem/FileOperations/copyDirRecursiveSpec/noPerms/inputDir/inputFile2 Normal file
View File

@ -0,0 +1,4 @@
dadasasddas
das
sda
sda

0
test/FileSystem/FileOperations/copyDirRecursiveSpec/noWritePerm/.keep Normal file
View File

0
test/FileSystem/FileOperations/copyDirRecursiveSpec/wrongInput Normal file
View File

1
test/FileSystem/FileOperations/copyDirRecursiveSpec/wrongInputSymL Symbolic link
View File

@ -0,0 +1 @@
inputDir/

16
test/FileSystem/FileOperations/copyFileOverwriteSpec/alreadyExists Normal file
View File

@ -0,0 +1,16 @@
adaöölsdaöl
dsalö
ölsda
ääödsf
äsdfä
öä453
öä
435
ä45343
5
453
453453453
das
asd
das

0
test/FileSystem/FileOperations/copyFileOverwriteSpec/alreadyExistsD/.keep Normal file
View File

4
test/FileSystem/FileOperations/copyFileOverwriteSpec/inputFile Normal file
View File

@ -0,0 +1,4 @@
abc
def
dsadasdsa

1
test/FileSystem/FileOperations/copyFileOverwriteSpec/inputFileSymL Symbolic link
View File

@ -0,0 +1 @@
inputFile

0
test/FileSystem/FileOperations/copyFileOverwriteSpec/noPerms/inputFile Normal file
View File

0
test/FileSystem/FileOperations/copyFileOverwriteSpec/outputDirNoWrite/.keep Normal file
View File

0
test/FileSystem/FileOperations/copyFileOverwriteSpec/wrongInput/.keep Normal file
View File

0
test/FileSystem/FileOperations/copyFileSpec/alreadyExists Normal file
View File

0
test/FileSystem/FileOperations/copyFileSpec/alreadyExistsD/.keep Normal file
View File

2
test/FileSystem/FileOperations/copyFileSpec/inputFile Normal file
View File

@ -0,0 +1,2 @@
abc
def

1
test/FileSystem/FileOperations/copyFileSpec/inputFileSymL Symbolic link
View File

@ -0,0 +1 @@
inputFile

0
test/FileSystem/FileOperations/copyFileSpec/noPerms/inputFile Normal file
View File

0
test/FileSystem/FileOperations/copyFileSpec/outputDirNoWrite/.keep Normal file
View File

0
test/FileSystem/FileOperations/copyFileSpec/wrongInput/.keep Normal file
View File

0
test/FileSystem/FileOperations/createDirSpec/.keep Normal file
View File

0
test/FileSystem/FileOperations/createDirSpec/alreadyExists/.keep Normal file
View File

0
test/FileSystem/FileOperations/createDirSpec/noPerms/.keep Normal file
View File

0
test/FileSystem/FileOperations/createDirSpec/noWritePerms/.keep Normal file
View File

0
test/FileSystem/FileOperations/createRegularFileSpec/alreadyExists Normal file
View File

0
test/FileSystem/FileOperations/createRegularFileSpec/noPerms/.keep Normal file
View File

0
test/FileSystem/FileOperations/createRegularFileSpec/noWritePerms/.keep Normal file
View File

0
test/FileSystem/FileOperations/deleteDirRecursiveSpec/.keep Normal file
View File

0
test/FileSystem/FileOperations/deleteDirRecursiveSpec/dir/.keep Normal file
View File

1
test/FileSystem/FileOperations/deleteDirRecursiveSpec/dirSym Symbolic link
View File

@ -0,0 +1 @@
dir

0
test/FileSystem/FileOperations/deleteDirRecursiveSpec/file Normal file
View File

0
test/FileSystem/FileOperations/deleteDirRecursiveSpec/noPerms/.keep Normal file
View File

0
test/FileSystem/FileOperations/deleteDirRecursiveSpec/noWritable/.keep Normal file
View File

0
test/FileSystem/FileOperations/deleteDirSpec/.keep Normal file
View File

0
test/FileSystem/FileOperations/deleteDirSpec/dir/.keep Normal file
View File

Some files were not shown because too many files have changed in this diff Show More