Compare commits
3 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
| a452b44cfe | |||
| 8bcdb84efd | |||
| 746daf9ba6 |
21
.gitignore
vendored
21
.gitignore
vendored
@ -1,15 +1,8 @@
|
||||
*.hp
|
||||
*.old
|
||||
*.prof
|
||||
*~
|
||||
.cabal-sandbox/
|
||||
.ghc.environment.*
|
||||
.liquid/
|
||||
.stack-work/
|
||||
3rdparty/hpath
|
||||
cabal.sandbox.config
|
||||
dist-newstyle/
|
||||
dist/
|
||||
hscope.out
|
||||
.ghcup
|
||||
/bin/
|
||||
.cabal-sandbox/
|
||||
cabal.sandbox.config
|
||||
*~
|
||||
*.hp
|
||||
*.prof
|
||||
*.old
|
||||
.liquid/
|
||||
|
||||
9
.gitmodules
vendored
Normal file
9
.gitmodules
vendored
Normal file
@ -0,0 +1,9 @@
|
||||
[submodule "3rdparty/hpath"]
|
||||
path = 3rdparty/hpath
|
||||
url = https://github.com/hasufell/hpath.git
|
||||
[submodule "3rdparty/hinotify"]
|
||||
path = 3rdparty/hinotify
|
||||
url = https://github.com/hasufell/hinotify.git
|
||||
[submodule "3rdparty/simple-sendfile"]
|
||||
path = 3rdparty/simple-sendfile
|
||||
url = https://github.com/hasufell/simple-sendfile.git
|
||||
68
.travis.yml
68
.travis.yml
@ -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/hinotify
vendored
Submodule
1
3rdparty/hinotify
vendored
Submodule
@ -0,0 +1 @@
|
||||
Subproject commit 6751bf0cc84ac8792d9636ede047ce567ef28469
|
||||
1
3rdparty/hpath
vendored
Submodule
1
3rdparty/hpath
vendored
Submodule
@ -0,0 +1 @@
|
||||
Subproject commit 45b515d1db98e795b5aba58e0867739bbc582955
|
||||
1
3rdparty/simple-sendfile
vendored
Submodule
1
3rdparty/simple-sendfile
vendored
Submodule
@ -0,0 +1 @@
|
||||
Subproject commit 869c69d3365b61831243989b81f26a2364f24f61
|
||||
16
README.md
16
README.md
@ -1,8 +1,7 @@
|
||||
HSFM
|
||||
====
|
||||
|
||||
[](https://gitter.im/hasufell/hsfm?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)
|
||||
[](https://travis-ci.org/hasufell/hsfm)
|
||||
__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.__
|
||||
|
||||
A Gtk+:3 filemanager written in Haskell.
|
||||
|
||||
@ -16,13 +15,22 @@ Design goals:
|
||||
Screenshots
|
||||
-----------
|
||||
|
||||
|
||||
|
||||
|
||||
Installation
|
||||
------------
|
||||
|
||||
```
|
||||
./install.sh
|
||||
git submodule update --init --recursive
|
||||
cabal sandbox init
|
||||
cabal sandbox add-source 3rdparty/hinotify
|
||||
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
|
||||
```
|
||||
|
||||
|
||||
|
||||
@ -1,10 +0,0 @@
|
||||
with-compiler: ghc-8.6.5
|
||||
|
||||
packages: .
|
||||
|
||||
optimization: 2
|
||||
|
||||
package *
|
||||
optimization: 2
|
||||
|
||||
index-state: 2020-01-24T20:23:40Z
|
||||
@ -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
|
||||
@ -1,5 +1,5 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<!-- Generated with glade 3.20.0 -->
|
||||
<!-- Generated with glade 3.18.3 -->
|
||||
<interface>
|
||||
<requires lib="gtk+" version="3.16"/>
|
||||
<object class="GtkGrid" id="fpropGrid">
|
||||
@ -361,123 +361,38 @@
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkBox">
|
||||
<object class="GtkNotebook" id="notebook">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="can_focus">True</property>
|
||||
<child>
|
||||
<object class="GtkPaned">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<child>
|
||||
<object class="GtkNotebook" id="notebook1">
|
||||
<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>
|
||||
<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>
|
||||
<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="expand">True</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="position">1</property>
|
||||
<property name="position">2</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkBox" id="box3">
|
||||
<property name="visible">True</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>
|
||||
<object class="GtkStatusbar" id="statusBar">
|
||||
<property name="visible">True</property>
|
||||
@ -494,7 +409,7 @@
|
||||
<packing>
|
||||
<property name="expand">True</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="position">2</property>
|
||||
<property name="position">0</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
@ -511,48 +426,14 @@
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="position">3</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>
|
||||
<property name="position">1</property>
|
||||
</packing>
|
||||
</child>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="position">2</property>
|
||||
<property name="position">3</property>
|
||||
</packing>
|
||||
</child>
|
||||
</object>
|
||||
@ -578,16 +459,6 @@
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-zoom-fit</property>
|
||||
</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">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
@ -638,30 +509,6 @@
|
||||
<property name="use_stock">False</property>
|
||||
</object>
|
||||
</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>
|
||||
</child>
|
||||
</object>
|
||||
@ -695,6 +542,7 @@
|
||||
<property name="label">Rename</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="image">image1</property>
|
||||
<property name="use_stock">False</property>
|
||||
</object>
|
||||
</child>
|
||||
@ -765,16 +613,6 @@
|
||||
</object>
|
||||
</child>
|
||||
</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">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
@ -784,37 +622,24 @@
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<child>
|
||||
<object class="GtkButton" id="backViewB">
|
||||
<object class="GtkEntry" id="urlBar">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="receives_default">True</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>
|
||||
<property name="input_purpose">url</property>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="expand">True</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="padding">2</property>
|
||||
<property name="position">0</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkButton" id="upViewB">
|
||||
<property name="label">gtk-go-up</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="receives_default">True</property>
|
||||
<child>
|
||||
<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>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
@ -824,37 +649,26 @@
|
||||
</packing>
|
||||
</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="can_focus">True</property>
|
||||
<property name="receives_default">True</property>
|
||||
<child>
|
||||
<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>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="padding">2</property>
|
||||
<property name="position">2</property>
|
||||
</packing>
|
||||
</child>
|
||||
<child>
|
||||
<object class="GtkButton" id="refreshViewB">
|
||||
<property name="label">gtk-refresh</property>
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">True</property>
|
||||
<property name="receives_default">True</property>
|
||||
<child>
|
||||
<object class="GtkImage" id="imageRefresh">
|
||||
<property name="visible">True</property>
|
||||
<property name="can_focus">False</property>
|
||||
<property name="stock">gtk-refresh</property>
|
||||
</object>
|
||||
</child>
|
||||
<property name="use_stock">True</property>
|
||||
</object>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
@ -863,37 +677,6 @@
|
||||
<property name="position">3</property>
|
||||
</packing>
|
||||
</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>
|
||||
<packing>
|
||||
<property name="expand">False</property>
|
||||
@ -915,7 +698,7 @@
|
||||
<packing>
|
||||
<property name="expand">True</property>
|
||||
<property name="fill">True</property>
|
||||
<property name="position">2</property>
|
||||
<property name="position">1</property>
|
||||
</packing>
|
||||
</child>
|
||||
</object>
|
||||
|
||||
@ -19,6 +19,20 @@ documentation.
|
||||
|
||||
## 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
|
||||
[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
|
||||
@ -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")
|
||||
* 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
|
||||
based. Some provide dedicated `Foo.ByteString` modules though, but it
|
||||
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
|
||||
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
|
||||
* 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
|
||||
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
|
||||
|
||||
@ -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
|
||||
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
|
||||
`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
|
||||
functions like `bracket` directly in our low-level code in case
|
||||
|
||||
65
hsfm.cabal
65
hsfm.cabal
@ -10,7 +10,7 @@ copyright: Copyright: (c) 2016 Julian Ospald
|
||||
homepage: https://github.com/hasufell/hsfm
|
||||
category: Desktop
|
||||
build-type: Simple
|
||||
cabal-version: >=1.22
|
||||
cabal-version: >=1.10
|
||||
|
||||
data-files:
|
||||
LICENSE
|
||||
@ -24,27 +24,36 @@ data-files:
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
HSFM.FileSystem.Errors
|
||||
HSFM.FileSystem.FileOperations
|
||||
HSFM.FileSystem.FileType
|
||||
HSFM.FileSystem.UtilTypes
|
||||
HSFM.History
|
||||
HSFM.Settings
|
||||
HSFM.Settings.Bookmarks
|
||||
HSFM.Utils.IO
|
||||
HSFM.Utils.MyPrelude
|
||||
|
||||
build-depends:
|
||||
IfElse,
|
||||
base >= 4.8 && < 5,
|
||||
attoparsec,
|
||||
base >= 4.7,
|
||||
bytestring,
|
||||
containers,
|
||||
data-default,
|
||||
errors,
|
||||
filepath >= 1.3.0.0,
|
||||
hinotify-bytestring,
|
||||
hpath >= 0.11.0 ,
|
||||
hpath-filepath >= 0.10.3,
|
||||
hpath-io >= 0.12.0,
|
||||
hinotify,
|
||||
hpath,
|
||||
monad-loops,
|
||||
mtl >= 2.2,
|
||||
old-locale >= 1,
|
||||
posix-paths,
|
||||
process,
|
||||
safe,
|
||||
simple-sendfile,
|
||||
stm,
|
||||
time >= 1.4.2,
|
||||
unix,
|
||||
utf8-string
|
||||
unix-bytestring,
|
||||
utf8-string,
|
||||
word8
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
Default-Extensions: RecordWildCards
|
||||
@ -52,46 +61,40 @@ library
|
||||
FlexibleInstances
|
||||
ViewPatterns
|
||||
ghc-options:
|
||||
-O2
|
||||
-threaded
|
||||
-Wall
|
||||
"-with-rtsopts=-N"
|
||||
|
||||
executable hsfm-gtk
|
||||
main-is: HSFM/GUI/Gtk.hs
|
||||
other-modules:
|
||||
Paths_hsfm
|
||||
HSFM.FileSystem.FileType
|
||||
HSFM.FileSystem.UtilTypes
|
||||
HSFM.GUI.Glib.GlibString
|
||||
HSFM.GUI.Gtk.Callbacks
|
||||
HSFM.GUI.Gtk.Callbacks.Utils
|
||||
HSFM.GUI.Gtk.Data
|
||||
HSFM.GUI.Gtk.Dialogs
|
||||
HSFM.GUI.Gtk.Errors
|
||||
HSFM.GUI.Gtk.Icons
|
||||
HSFM.GUI.Gtk.MyGUI
|
||||
HSFM.GUI.Gtk.MyView
|
||||
HSFM.GUI.Gtk.Plugins
|
||||
HSFM.GUI.Gtk.Settings
|
||||
HSFM.GUI.Gtk.Utils
|
||||
HSFM.History
|
||||
HSFM.Settings
|
||||
HSFM.Utils.IO
|
||||
HSFM.Utils.MyPrelude
|
||||
|
||||
build-depends:
|
||||
Cabal >= 1.22.0.0,
|
||||
IfElse,
|
||||
base >= 4.8 && < 5,
|
||||
base >= 4.7,
|
||||
bytestring,
|
||||
containers,
|
||||
data-default,
|
||||
filepath >= 1.3.0.0,
|
||||
glib >= 0.13,
|
||||
gtk3 >= 0.14.1,
|
||||
hinotify-bytestring,
|
||||
hpath >= 0.11.0 ,
|
||||
hpath-filepath >= 0.10.3,
|
||||
hpath-io >= 0.12.0,
|
||||
hinotify,
|
||||
hpath,
|
||||
hsfm,
|
||||
monad-loops,
|
||||
mtl >= 2.2,
|
||||
old-locale >= 1,
|
||||
posix-paths,
|
||||
process,
|
||||
safe,
|
||||
simple-sendfile,
|
||||
@ -109,9 +112,7 @@ executable hsfm-gtk
|
||||
FlexibleInstances
|
||||
ViewPatterns
|
||||
ghc-options:
|
||||
-O2
|
||||
-threaded
|
||||
-Wall
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/hasufell/hsfm
|
||||
|
||||
"-with-rtsopts=-N"
|
||||
|
||||
42
install.sh
42
install.sh
@ -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"
|
||||
|
||||
251
src/HSFM/FileSystem/Errors.hs
Normal file
251
src/HSFM/FileSystem/Errors.hs
Normal file
@ -0,0 +1,251 @@
|
||||
{--
|
||||
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 #-}
|
||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||
|
||||
-- |Provides error handling.
|
||||
module HSFM.FileSystem.Errors where
|
||||
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
(
|
||||
when
|
||||
, forM
|
||||
)
|
||||
import Data.ByteString
|
||||
(
|
||||
ByteString
|
||||
)
|
||||
import Data.Typeable
|
||||
import Foreign.C.Error
|
||||
(
|
||||
getErrno
|
||||
, Errno
|
||||
)
|
||||
import qualified HPath as P
|
||||
import HPath
|
||||
(
|
||||
Abs
|
||||
, Path
|
||||
)
|
||||
import HSFM.Utils.IO
|
||||
import System.IO.Error
|
||||
(
|
||||
catchIOError
|
||||
)
|
||||
|
||||
import qualified System.Posix.Directory.ByteString as PFD
|
||||
import System.Posix.FilePath
|
||||
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)
|
||||
|
||||
|
||||
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
|
||||
|
||||
|
||||
|
||||
|
||||
----------------------------
|
||||
--[ 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 =
|
||||
whenM (doesFileExist fp) (throw . FileDoesExist
|
||||
. P.fromAbs $ fp)
|
||||
|
||||
|
||||
throwDirDoesNotExist :: Path Abs -> IO ()
|
||||
throwDirDoesNotExist fp =
|
||||
whenM (doesDirectoryExist fp) (throw . DirDoesExist
|
||||
. P.fromAbs $ fp)
|
||||
|
||||
|
||||
throwSameFile :: Path Abs -- ^ will be canonicalized
|
||||
-> Path Abs -- ^ will be canonicalized
|
||||
-> IO ()
|
||||
throwSameFile fp1 fp2 = do
|
||||
fp1' <- fmap P.fromAbs $ P.canonicalizePath fp1
|
||||
-- TODO: clean this up... if canonicalizing fp2 fails we try to
|
||||
-- canonicalize `dirname fp2`
|
||||
fp2' <- catchIOError (fmap P.fromAbs $ P.canonicalizePath fp2)
|
||||
(\_ -> fmap P.fromAbs
|
||||
$ (\x -> maybe x (\y -> x P.</> y) $ P.basename fp2)
|
||||
<$> (P.canonicalizePath $ P.dirname fp2))
|
||||
when (equalFilePath fp1' fp2') (throw $ SameFile fp1' fp2')
|
||||
|
||||
|
||||
-- |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
|
||||
source' <- P.canonicalizePath source
|
||||
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.getSymbolicLinkStatus (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. This follows
|
||||
-- symlinks, but will return True if the symlink is broken.
|
||||
doesFileExist :: Path Abs -> IO Bool
|
||||
doesFileExist fp =
|
||||
handleIOError (\_ -> return False) $ do
|
||||
fp' <- fmap P.fromAbs $ P.canonicalizePath fp
|
||||
fs <- PF.getFileStatus fp'
|
||||
return $ not . PF.isDirectory $ fs
|
||||
|
||||
|
||||
-- |Checks if the given file exists and is a directory. This follows
|
||||
-- symlinks, but will return False if the symlink is broken.
|
||||
doesDirectoryExist :: Path Abs -> IO Bool
|
||||
doesDirectoryExist fp =
|
||||
handleIOError (\_ -> return False) $ do
|
||||
fp' <- fmap P.fromAbs $ P.canonicalizePath fp
|
||||
fs <- PF.getFileStatus fp'
|
||||
return $ PF.isDirectory fs
|
||||
|
||||
|
||||
-- |Checks whether the directory at the given path exists and can be
|
||||
-- opened. This invokes `openDirStream`.
|
||||
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
|
||||
|
||||
650
src/HSFM/FileSystem/FileOperations.hs
Normal file
650
src/HSFM/FileSystem/FileOperations.hs
Normal file
@ -0,0 +1,650 @@
|
||||
{--
|
||||
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 #-}
|
||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||
|
||||
-- |This module provides all the atomic IO related file operations like
|
||||
-- copy, delete, move and so on. It operates primarily on `AnchoredFile`, which
|
||||
-- is guaranteed to be well-formed.
|
||||
--
|
||||
-- It would be nicer to pass states around, but the filesystem state changes
|
||||
-- too quickly and cannot be relied upon. Lazy implementations of filesystem
|
||||
-- trees have been tried as well, but they can introduce subtle bugs.
|
||||
module HSFM.FileSystem.FileOperations where
|
||||
|
||||
|
||||
import Control.Exception
|
||||
(
|
||||
bracket
|
||||
, throw
|
||||
)
|
||||
import Control.Monad
|
||||
(
|
||||
forM_
|
||||
, unless
|
||||
, void
|
||||
, when
|
||||
)
|
||||
import Control.Monad.Loops
|
||||
(
|
||||
dropWhileM
|
||||
)
|
||||
import Data.ByteString
|
||||
(
|
||||
ByteString
|
||||
)
|
||||
import Data.Foldable
|
||||
(
|
||||
for_
|
||||
)
|
||||
import Data.Word
|
||||
(
|
||||
Word8
|
||||
)
|
||||
import Foreign.C.Error
|
||||
(
|
||||
eXDEV
|
||||
, eINVAL
|
||||
, eNOSYS
|
||||
)
|
||||
import Foreign.C.Types
|
||||
(
|
||||
CSize
|
||||
)
|
||||
import Foreign.Marshal.Alloc
|
||||
(
|
||||
allocaBytes
|
||||
)
|
||||
import Foreign.Ptr
|
||||
(
|
||||
Ptr
|
||||
)
|
||||
import HPath
|
||||
(
|
||||
Path
|
||||
, Abs
|
||||
, Fn
|
||||
)
|
||||
import qualified HPath as P
|
||||
import HSFM.FileSystem.Errors
|
||||
import HSFM.FileSystem.FileType
|
||||
import HSFM.Utils.IO
|
||||
import Prelude hiding (readFile, writeFile)
|
||||
import System.Posix.Directory.ByteString
|
||||
(
|
||||
createDirectory
|
||||
, removeDirectory
|
||||
)
|
||||
import System.Posix.Files.ByteString
|
||||
(
|
||||
createSymbolicLink
|
||||
, fileMode
|
||||
, getFdStatus
|
||||
, groupExecuteMode
|
||||
, groupReadMode
|
||||
, groupWriteMode
|
||||
, otherExecuteMode
|
||||
, otherReadMode
|
||||
, otherWriteMode
|
||||
, ownerModes
|
||||
, ownerReadMode
|
||||
, ownerWriteMode
|
||||
, readSymbolicLink
|
||||
, removeLink
|
||||
, rename
|
||||
, 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 System.Posix.IO.Sendfile.ByteString
|
||||
(
|
||||
sendfileFd
|
||||
, FileRange(EntireFile)
|
||||
)
|
||||
import qualified System.Posix.Process.ByteString as SPP
|
||||
import System.Posix.Types
|
||||
(
|
||||
ByteCount
|
||||
, Fd
|
||||
, FileMode
|
||||
, ProcessID
|
||||
)
|
||||
|
||||
|
||||
|
||||
-- TODO: file operations should be threaded and not block the UI
|
||||
-- TODO: make sure we do the right thing for BlockDev, CharDev etc...
|
||||
-- most operations are not implemented for these
|
||||
|
||||
|
||||
-- |Data type describing an actual file operation that can be
|
||||
-- carried out via `doFile`. Useful to build up a list of operations
|
||||
-- or delay operations.
|
||||
data FileOperation = FCopy Copy
|
||||
| FMove Move
|
||||
| FDelete [Path Abs]
|
||||
| FOpen (Path Abs)
|
||||
| FExecute (Path Abs) [ByteString]
|
||||
| None
|
||||
|
||||
|
||||
-- |Data type describing partial or complete file copy operation.
|
||||
-- CC stands for a complete operation and can be used for `runFileOp`.
|
||||
data Copy = CP1 [Path Abs]
|
||||
| CP2 [Path Abs]
|
||||
(Path Abs)
|
||||
| CC [Path Abs]
|
||||
(Path Abs)
|
||||
CopyMode
|
||||
|
||||
|
||||
-- |Data type describing partial or complete file move operation.
|
||||
-- MC stands for a complete operation and can be used for `runFileOp`.
|
||||
data Move = MP1 [Path Abs]
|
||||
| MC [Path Abs]
|
||||
(Path Abs)
|
||||
CopyMode
|
||||
|
||||
|
||||
-- |Copy modes.
|
||||
data CopyMode = Strict -- ^ fail if the target already exists
|
||||
| Merge -- ^ overwrite files if necessary, for files, this
|
||||
-- is the same as Replace
|
||||
| Replace -- ^ remove targets before copying, this is
|
||||
-- only useful if the target is a directorty
|
||||
| Rename (Path Fn)
|
||||
|
||||
|
||||
-- |Run a given FileOperation. If the FileOperation is partial, it will
|
||||
-- be returned. Returns `Nothing` on success.
|
||||
--
|
||||
-- Since file operations can be delayed, this is `Path Abs` based, not
|
||||
-- `File` based. This makes sure we don't have stale
|
||||
-- file information.
|
||||
runFileOp :: FileOperation -> IO (Maybe FileOperation)
|
||||
runFileOp fo' =
|
||||
case fo' of
|
||||
(FCopy (CC froms to cm)) -> do
|
||||
froms' <- mapM toAfile froms
|
||||
to' <- toAfile to
|
||||
when (anyFailed froms')
|
||||
(throw . CopyFailed $ "File in copy buffer does not exist anymore!")
|
||||
mapM_ (\x -> easyCopy cm x to') froms'
|
||||
>> return Nothing
|
||||
(FCopy fo) -> return $ Just $ FCopy fo
|
||||
(FMove (MC froms to cm)) -> do
|
||||
froms' <- mapM toAfile froms
|
||||
to' <- toAfile to
|
||||
when (anyFailed froms')
|
||||
(throw . MoveFailed $ "File in move buffer does not exist anymore!")
|
||||
mapM_ (\x -> easyMove cm x to') froms'
|
||||
>> return Nothing
|
||||
(FMove fo) -> return $ Just $ FMove fo
|
||||
(FDelete fps) -> do
|
||||
fps' <- mapM toAfile fps
|
||||
mapM_ easyDelete fps' >> return Nothing
|
||||
(FOpen fp) ->
|
||||
toAfile fp >>= openFile >> return Nothing
|
||||
(FExecute fp args) ->
|
||||
toAfile fp >>= flip executeFile args >> return Nothing
|
||||
_ -> return Nothing
|
||||
where
|
||||
toAfile = readFile (\_ -> return undefined)
|
||||
|
||||
|
||||
|
||||
--------------------
|
||||
--[ File Copying ]--
|
||||
--------------------
|
||||
|
||||
|
||||
-- |Copies a directory to the given destination with the specified
|
||||
-- `DirCopyMode`. Excludes symlinks.
|
||||
copyDir :: CopyMode
|
||||
-> File a -- ^ source dir
|
||||
-> File a -- ^ destination dir
|
||||
-> Path Fn -- ^ destination dir name
|
||||
-> IO ()
|
||||
copyDir (Rename fn)
|
||||
from@Dir{}
|
||||
to@Dir{}
|
||||
_
|
||||
= copyDir Strict from to fn
|
||||
-- this branch must never get `Rename` as CopyMode
|
||||
copyDir cm from@Dir{ path = fromp }
|
||||
to@Dir{ path = top }
|
||||
fn
|
||||
= do
|
||||
let destdirp = top P.</> fn
|
||||
-- for performance, sanity checks are only done for the top dir
|
||||
throwDestinationInSource fromp destdirp
|
||||
throwSameFile fromp destdirp
|
||||
throwCantOpenDirectory fromp
|
||||
throwCantOpenDirectory top
|
||||
go cm from to fn
|
||||
where
|
||||
go :: CopyMode -> File a -> File a -> Path Fn -> IO ()
|
||||
go cm' Dir{ path = fromp' }
|
||||
Dir{ path = top' }
|
||||
fn' = do
|
||||
fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus
|
||||
(P.fromAbs fromp')
|
||||
createDestdir (top' P.</> fn') fmode'
|
||||
destdir <- readFile (\_ -> return undefined)
|
||||
(top' P.</> fn')
|
||||
contents <- readDirectoryContents
|
||||
(\_ -> return undefined) fromp'
|
||||
|
||||
for_ contents $ \f ->
|
||||
case f of
|
||||
SymLink{ path = fp' } -> recreateSymlink cm' f destdir
|
||||
=<< (P.basename fp')
|
||||
Dir{ path = fp' } -> go cm' f destdir
|
||||
=<< (P.basename fp')
|
||||
RegFile{ path = fp' } -> unsafeCopyFile Replace f destdir
|
||||
=<< (P.basename fp')
|
||||
_ -> return ()
|
||||
where
|
||||
createDestdir destdir fmode' =
|
||||
let destdir' = P.toFilePath destdir
|
||||
in case cm' of
|
||||
Merge ->
|
||||
unlessM (doesDirectoryExist destdir)
|
||||
(createDirectory destdir' fmode')
|
||||
Strict -> do
|
||||
throwDirDoesExist destdir
|
||||
createDirectory destdir' fmode'
|
||||
Replace -> do
|
||||
whenM (doesDirectoryExist destdir)
|
||||
(deleteDirRecursive =<<
|
||||
readFile
|
||||
(\_ -> return undefined) destdir)
|
||||
createDirectory destdir' fmode'
|
||||
_ -> throw $ InvalidOperation "Internal error, wrong CopyMode!"
|
||||
go _ _ _ _ = throw $ InvalidOperation "wrong input type"
|
||||
copyDir _ _ _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |Recreate a symlink.
|
||||
recreateSymlink :: CopyMode
|
||||
-> File a -- ^ the old symlink file
|
||||
-> File a -- ^ destination dir of the
|
||||
-- new symlink file
|
||||
-> Path Fn -- ^ destination file name
|
||||
-> IO ()
|
||||
recreateSymlink (Rename pn) symf@SymLink{} symdest@Dir{} _
|
||||
= recreateSymlink Strict symf symdest pn
|
||||
recreateSymlink cm SymLink{ path = sfp } Dir{ path = sdp } fn
|
||||
= do
|
||||
throwCantOpenDirectory sdp
|
||||
sympoint <- readSymbolicLink (P.fromAbs sfp)
|
||||
let symname = sdp P.</> fn
|
||||
case cm of
|
||||
Merge -> delOld symname
|
||||
Replace -> delOld symname
|
||||
_ -> return ()
|
||||
createSymbolicLink sympoint (P.fromAbs symname)
|
||||
where
|
||||
delOld symname = do
|
||||
f <- readFile (\_ -> return undefined) symname
|
||||
unless (failed f)
|
||||
(easyDelete f)
|
||||
recreateSymlink _ _ _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |Copies the given regular file to the given dir with the given filename.
|
||||
-- Excludes symlinks.
|
||||
copyFile :: CopyMode
|
||||
-> File a -- ^ source file
|
||||
-> File a -- ^ destination dir
|
||||
-> Path Fn -- ^ destination file name
|
||||
-> IO ()
|
||||
copyFile (Rename pn) from@RegFile{} to@Dir{} _
|
||||
= copyFile Strict from to pn
|
||||
copyFile cm from@RegFile{ path = fromp }
|
||||
tod@Dir{ path = todp } fn
|
||||
= do
|
||||
throwCantOpenDirectory todp
|
||||
throwCantOpenDirectory . P.dirname $ fromp
|
||||
throwSameFile fromp (todp P.</> fn)
|
||||
unsafeCopyFile cm from tod fn
|
||||
copyFile _ _ _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |Unsafe version of `copyFile` without initial sanity checks. This
|
||||
-- holds the actual copy logic though and is called by `copyFile` in the end.
|
||||
-- It's also used for cases where we don't need/want sanity checks
|
||||
-- and need the extra bit of performance.
|
||||
unsafeCopyFile :: CopyMode
|
||||
-> File a -- ^ source file
|
||||
-> File a -- ^ destination dir
|
||||
-> Path Fn -- ^ destination file name
|
||||
-> IO ()
|
||||
unsafeCopyFile (Rename pn) from@RegFile{} to@Dir{} _
|
||||
= copyFile Strict from to pn
|
||||
unsafeCopyFile cm RegFile{ path = fromp }
|
||||
Dir{ path = todp } fn
|
||||
= do
|
||||
let to = todp P.</> fn
|
||||
case cm of
|
||||
Strict -> throwFileDoesExist to
|
||||
_ -> return ()
|
||||
|
||||
-- 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 fromp $ \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 =
|
||||
-- NOTE: we are not blocking IO here, O_NONBLOCK is false
|
||||
-- for `defaultFileFlags`
|
||||
bracket (SPI.openFd source SPI.ReadOnly Nothing SPI.defaultFileFlags)
|
||||
SPI.closeFd
|
||||
$ \sfd -> do
|
||||
fileM <- System.Posix.Files.ByteString.fileMode
|
||||
<$> getFdStatus sfd
|
||||
bracket (SPI.openFd dest SPI.WriteOnly (Just fileM)
|
||||
SPI.defaultFileFlags)
|
||||
SPI.closeFd
|
||||
$ \dfd -> sendfileFd dfd sfd EntireFile
|
||||
-- low-level copy operation utilizing read(2)/write(2)
|
||||
-- in case `sendFileCopy` fails/is unsupported
|
||||
fallbackCopy source dest =
|
||||
bracket (SPI.openFd source SPI.ReadOnly Nothing SPI.defaultFileFlags)
|
||||
SPI.closeFd
|
||||
$ \sfd -> do
|
||||
fileM <- System.Posix.Files.ByteString.fileMode
|
||||
<$> getFdStatus sfd
|
||||
bracket (SPI.openFd dest SPI.WriteOnly (Just fileM)
|
||||
SPI.defaultFileFlags)
|
||||
SPI.closeFd
|
||||
$ \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
|
||||
when (rsize /= size) (throw . CopyFailed $ "wrong size!")
|
||||
write' sfd dfd buf (totalsize + fromIntegral size)
|
||||
unsafeCopyFile _ _ _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |Copies a regular file, directory or symlink. In case of a symlink,
|
||||
-- it is just recreated, even if it points to a directory.
|
||||
easyCopy :: CopyMode
|
||||
-> File a
|
||||
-> File a
|
||||
-> IO ()
|
||||
easyCopy cm from@SymLink{}
|
||||
to@Dir{}
|
||||
= recreateSymlink cm from to =<< (P.basename . path $ from)
|
||||
easyCopy cm from@RegFile{}
|
||||
to@Dir{}
|
||||
= copyFile cm from to =<< (P.basename . path $ from)
|
||||
easyCopy cm from@Dir{}
|
||||
to@Dir{}
|
||||
= copyDir cm from to =<< (P.basename . path $ from)
|
||||
easyCopy _ _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |Write a ByteString to a file, overwriting the file. Follows
|
||||
-- symbolic links.
|
||||
writeFile :: File a -> ByteString -> IO ByteCount
|
||||
writeFile RegFile { path = fp } bs = P.withAbsPath fp $ \p ->
|
||||
bracket (SPI.openFd p SPI.WriteOnly (Just PF.stdFileMode)
|
||||
SPI.defaultFileFlags)
|
||||
SPI.closeFd
|
||||
$ \fd -> SPB.fdWrite fd bs
|
||||
writeFile SymLink { sdest = file@RegFile{} } bs =
|
||||
writeFile file bs
|
||||
writeFile _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
readFileContents :: File FileInfo -> IO ByteString
|
||||
readFileContents RegFile { path = fp } =
|
||||
P.withAbsPath fp $ \p ->
|
||||
bracket (SPI.openFd p SPI.ReadOnly Nothing SPI.defaultFileFlags)
|
||||
SPI.closeFd
|
||||
$ \fd -> do
|
||||
fs <- PF.getFdStatus fd
|
||||
SPB.fdRead fd (fromIntegral $ PF.fileSize fs)
|
||||
readFileContents SymLink { sdest = file@RegFile{} } =
|
||||
readFileContents file
|
||||
readFileContents _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------
|
||||
--[ File Deletion ]--
|
||||
---------------------
|
||||
|
||||
|
||||
-- |Deletes a symlink, which can either point to a file or directory.
|
||||
deleteSymlink :: File a -> IO ()
|
||||
deleteSymlink SymLink{ path = fp }
|
||||
= P.withAbsPath fp removeLink
|
||||
deleteSymlink _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |Deletes the given regular file, never symlinks.
|
||||
deleteFile :: File a -> IO ()
|
||||
deleteFile RegFile{ path = fp }
|
||||
= P.withAbsPath fp removeLink
|
||||
deleteFile _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |Deletes the given directory, never symlinks.
|
||||
deleteDir :: File a -> IO ()
|
||||
deleteDir Dir{ path = fp }
|
||||
= P.withAbsPath fp removeDirectory
|
||||
deleteDir _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |Deletes the given directory recursively.
|
||||
deleteDirRecursive :: File a -> IO ()
|
||||
deleteDirRecursive f'@Dir{ path = fp' } = do
|
||||
throwCantOpenDirectory fp'
|
||||
go f'
|
||||
where
|
||||
go :: File a -> IO ()
|
||||
go Dir{ path = fp } = do
|
||||
files <- readDirectoryContents
|
||||
(\_ -> return undefined) fp
|
||||
for_ files $ \file ->
|
||||
case file of
|
||||
SymLink{} -> deleteSymlink file
|
||||
Dir{} -> go file
|
||||
RegFile{ path = rfp }
|
||||
-> P.withAbsPath rfp removeLink
|
||||
_ -> throw $ FileDoesExist
|
||||
(P.toFilePath . path $ file)
|
||||
removeDirectory . P.toFilePath $ fp
|
||||
go _ = throw $ InvalidOperation "wrong input type"
|
||||
deleteDirRecursive _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |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.
|
||||
easyDelete :: File a -> IO ()
|
||||
easyDelete f@SymLink{} = deleteSymlink f
|
||||
easyDelete f@RegFile{}
|
||||
= deleteFile f
|
||||
easyDelete f@Dir{}
|
||||
= deleteDirRecursive f
|
||||
easyDelete _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
|
||||
|
||||
--------------------
|
||||
--[ File Opening ]--
|
||||
--------------------
|
||||
|
||||
|
||||
-- |Opens a file appropriately by invoking xdg-open. The file type
|
||||
-- is not checked.
|
||||
openFile :: File a
|
||||
-> IO ProcessID
|
||||
openFile f =
|
||||
P.withAbsPath (path f) $ \fp ->
|
||||
SPP.forkProcess $ SPP.executeFile "xdg-open" True [fp] Nothing
|
||||
|
||||
|
||||
-- |Executes a program with the given arguments.
|
||||
executeFile :: File a -- ^ program
|
||||
-> [ByteString] -- ^ arguments
|
||||
-> IO ProcessID
|
||||
executeFile RegFile{ path = fp } args
|
||||
= P.withAbsPath fp $ \fpb ->
|
||||
SPP.forkProcess
|
||||
$ SPP.executeFile fpb True args Nothing
|
||||
executeFile SymLink{ path = fp, sdest = RegFile{} } args
|
||||
= P.withAbsPath fp $ \fpb ->
|
||||
SPP.forkProcess
|
||||
$ SPP.executeFile fpb True args Nothing
|
||||
executeFile _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------
|
||||
--[ File Creation ]--
|
||||
---------------------
|
||||
|
||||
|
||||
-- |Create an empty regular file at the given directory with the given filename.
|
||||
createFile :: File FileInfo -> Path Fn -> IO ()
|
||||
createFile (DirOrSym td) fn = do
|
||||
let fullp = path td P.</> fn
|
||||
throwFileDoesExist fullp
|
||||
fd <- SPI.createFile (P.fromAbs fullp) newFilePerms
|
||||
SPI.closeFd fd
|
||||
createFile _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |Create an empty directory at the given directory with the given filename.
|
||||
createDir :: File FileInfo -> Path Fn -> IO ()
|
||||
createDir (DirOrSym td) fn = do
|
||||
let fullp = path td P.</> fn
|
||||
throwDirDoesExist fullp
|
||||
createDirectory (P.fromAbs fullp) newDirPerms
|
||||
createDir _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |Create a directory at the given path, creating all parents if
|
||||
-- necessary.
|
||||
mkdirP :: Path Abs -> IO ()
|
||||
mkdirP p = do
|
||||
mkps <- dropWhileM canOpenDirectory (reverse $ p : P.getAllParents p)
|
||||
forM_ mkps $ \mkp -> createDirectory (P.fromAbs mkp) newDirPerms
|
||||
|
||||
|
||||
|
||||
|
||||
----------------------------
|
||||
--[ File Renaming/Moving ]--
|
||||
----------------------------
|
||||
|
||||
|
||||
-- |Rename a given file with the provided filename.
|
||||
renameFile :: File a -> Path Fn -> IO ()
|
||||
renameFile af fn = do
|
||||
let fromf = path af
|
||||
tof = (P.dirname . path $ af) P.</> fn
|
||||
throwFileDoesExist tof
|
||||
throwSameFile fromf tof
|
||||
rename (P.fromAbs fromf) (P.fromAbs tof)
|
||||
|
||||
|
||||
-- |Move a given file to the given target directory.
|
||||
moveFile :: CopyMode
|
||||
-> File a -- ^ file to move
|
||||
-> File a -- ^ base target directory
|
||||
-> Path Fn -- ^ target file name
|
||||
-> IO ()
|
||||
moveFile (Rename pn) from to@Dir{} _ =
|
||||
moveFile Strict from to pn
|
||||
moveFile cm from to@Dir{} fn = do
|
||||
let from' = path from
|
||||
froms' = P.fromAbs from'
|
||||
to' = path to P.</> fn
|
||||
tos' = P.fromAbs to'
|
||||
case cm of
|
||||
Strict -> throwFileDoesExist to'
|
||||
Merge -> delOld to'
|
||||
Replace -> delOld to'
|
||||
Rename _ -> throw $ InvalidOperation "Internal error! Wrong CopyMode!"
|
||||
throwSameFile from' to'
|
||||
catchErrno [eXDEV] (rename froms' tos') $ do
|
||||
easyCopy Strict from to
|
||||
easyDelete from
|
||||
where
|
||||
delOld fp = do
|
||||
to' <- readFile (\_ -> return undefined) fp
|
||||
unless (failed to') (easyDelete to')
|
||||
moveFile _ _ _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- |Like `moveFile` except it uses the filename of the source as target.
|
||||
easyMove :: CopyMode
|
||||
-> File a -- ^ file to move
|
||||
-> File a -- ^ base target directory
|
||||
-> IO ()
|
||||
easyMove cm from to = moveFile cm from to =<< (P.basename . path $ from)
|
||||
|
||||
|
||||
|
||||
-----------------------
|
||||
--[ 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
|
||||
|
||||
@ -18,29 +18,20 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
||||
|
||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||
|
||||
|
||||
-- |This module provides a data type for representing directories/files
|
||||
-- in a well-typed and convenient way. This is useful to gather and
|
||||
-- save information about a file, so the information can be easily
|
||||
-- processed in e.g. a GUI.
|
||||
-- |This module provides data types for representing directories/files
|
||||
-- and related operations on it, mostly internal stuff.
|
||||
--
|
||||
-- However, it's not meant to be used to interact with low-level
|
||||
-- functions that copy files etc, since there's no guarantee that
|
||||
-- the in-memory representation of the type still matches what is
|
||||
-- happening on filesystem level.
|
||||
--
|
||||
-- If you interact with low-level libraries, you must not pattern
|
||||
-- match on the `File a` type. Instead, you should only use the saved
|
||||
-- `path` and make no assumptions about the file the path might or
|
||||
-- might not point to.
|
||||
-- It doesn't allow to represent the whole filesystem, since that's only
|
||||
-- possible through IO laziness, which introduces too much internal state.
|
||||
module HSFM.FileSystem.FileType where
|
||||
|
||||
|
||||
|
||||
import Data.ByteString(ByteString)
|
||||
import Data.ByteString.UTF8
|
||||
import Data.Default
|
||||
import Data.Maybe
|
||||
(
|
||||
toString
|
||||
catMaybes
|
||||
)
|
||||
import Data.Time.Clock.POSIX
|
||||
(
|
||||
@ -48,22 +39,33 @@ import Data.Time.Clock.POSIX
|
||||
, posixSecondsToUTCTime
|
||||
)
|
||||
import Data.Time()
|
||||
import Foreign.C.Error
|
||||
(
|
||||
eACCES
|
||||
)
|
||||
import HPath
|
||||
(
|
||||
Abs
|
||||
, Path
|
||||
, Fn
|
||||
)
|
||||
import qualified HPath as P
|
||||
import HPath.IO hiding (FileType(..))
|
||||
import HPath.IO.Errors
|
||||
import HSFM.FileSystem.Errors
|
||||
import HSFM.Utils.MyPrelude
|
||||
import Prelude hiding(readFile)
|
||||
import System.IO.Error
|
||||
(
|
||||
ioeGetErrorType
|
||||
, isDoesNotExistErrorType
|
||||
)
|
||||
import System.Posix.FilePath
|
||||
(
|
||||
(</>)
|
||||
)
|
||||
import System.Posix.Directory.Traversals
|
||||
(
|
||||
realpath
|
||||
getDirectoryContents
|
||||
, realpath
|
||||
)
|
||||
import qualified System.Posix.Files.ByteString as PF
|
||||
import System.Posix.Types
|
||||
@ -91,9 +93,14 @@ import System.Posix.Types
|
||||
-- |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
|
||||
-- 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. an Exception
|
||||
-- can be converted to a String with 'show'.
|
||||
data File a =
|
||||
Dir {
|
||||
Failed {
|
||||
path :: !(Path Abs)
|
||||
, err :: IOError
|
||||
}
|
||||
| Dir {
|
||||
path :: !(Path Abs)
|
||||
, fvar :: a
|
||||
}
|
||||
@ -104,8 +111,8 @@ data File a =
|
||||
| SymLink {
|
||||
path :: !(Path Abs)
|
||||
, fvar :: a
|
||||
, sdest :: Maybe (File a) -- ^ symlink madness,
|
||||
-- we need to know where it points to
|
||||
, sdest :: File a -- ^ symlink madness,
|
||||
-- we need to know where it points to
|
||||
, rawdest :: !ByteString
|
||||
}
|
||||
| BlockDev {
|
||||
@ -176,31 +183,28 @@ fileLike f = (False, f)
|
||||
|
||||
|
||||
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
|
||||
-- return only the very first level
|
||||
-- TODO: this is probably obsolete now
|
||||
= case sdir s of
|
||||
(True, _) -> (True, f)
|
||||
_ -> (False, f)
|
||||
sdir f@SymLink{ sdest = Just Dir{} }
|
||||
sdir f@SymLink{ sdest = Dir{} }
|
||||
= (True, f)
|
||||
sdir f@Dir{} = (True, f)
|
||||
sdir f = (False, f)
|
||||
|
||||
|
||||
-- |Matches on any non-directory kind of files, excluding symlinks.
|
||||
pattern FileLike :: File FileInfo -> File FileInfo
|
||||
pattern FileLike f <- (fileLike -> (True, f))
|
||||
|
||||
-- |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)
|
||||
-> (True, fs))
|
||||
|
||||
-- |Matches a list of any non-directory kind of files or symlinks
|
||||
-- pointing to such.
|
||||
pattern FileLikeList :: [File FileInfo] -> [File FileInfo]
|
||||
pattern FileLikeList fs <- (\fs -> (and
|
||||
. fmap (fst . sfileLike)
|
||||
$ fs, fs) -> (True, fs))
|
||||
@ -215,33 +219,31 @@ brokenSymlink f = (isBrokenSymlink f, f)
|
||||
|
||||
|
||||
fileLikeSym :: File FileInfo -> (Bool, File FileInfo)
|
||||
fileLikeSym f@SymLink{ sdest = Just s@SymLink{} }
|
||||
fileLikeSym f@SymLink{ sdest = s@SymLink{} }
|
||||
= case fileLikeSym s of
|
||||
(True, _) -> (True, f)
|
||||
_ -> (False, f)
|
||||
fileLikeSym f@SymLink{ sdest = Just RegFile{} } = (True, f)
|
||||
fileLikeSym f@SymLink{ sdest = Just BlockDev{} } = (True, f)
|
||||
fileLikeSym f@SymLink{ sdest = Just CharDev{} } = (True, f)
|
||||
fileLikeSym f@SymLink{ sdest = Just NamedPipe{} } = (True, f)
|
||||
fileLikeSym f@SymLink{ sdest = Just Socket{} } = (True, f)
|
||||
fileLikeSym f@SymLink{ sdest = RegFile{} } = (True, f)
|
||||
fileLikeSym f@SymLink{ sdest = BlockDev{} } = (True, f)
|
||||
fileLikeSym f@SymLink{ sdest = CharDev{} } = (True, f)
|
||||
fileLikeSym f@SymLink{ sdest = NamedPipe{} } = (True, f)
|
||||
fileLikeSym f@SymLink{ sdest = Socket{} } = (True, f)
|
||||
fileLikeSym f = (False, f)
|
||||
|
||||
|
||||
dirSym :: File FileInfo -> (Bool, File FileInfo)
|
||||
dirSym f@SymLink{ sdest = Just s@SymLink{} }
|
||||
dirSym f@SymLink{ sdest = s@SymLink{} }
|
||||
= case dirSym s of
|
||||
(True, _) -> (True, f)
|
||||
_ -> (False, f)
|
||||
dirSym f@SymLink{ sdest = Just Dir{} } = (True, f)
|
||||
dirSym f@SymLink{ sdest = Dir{} } = (True, f)
|
||||
dirSym f = (False, f)
|
||||
|
||||
|
||||
-- |Matches on symlinks pointing to file-like files only.
|
||||
pattern FileLikeSym :: File FileInfo -> File FileInfo
|
||||
pattern FileLikeSym f <- (fileLikeSym -> (True, f))
|
||||
|
||||
-- |Matches on broken symbolic links.
|
||||
pattern BrokenSymlink :: File FileInfo -> File FileInfo
|
||||
pattern BrokenSymlink f <- (brokenSymlink -> (True, f))
|
||||
|
||||
|
||||
@ -249,11 +251,9 @@ pattern BrokenSymlink f <- (brokenSymlink -> (True, f))
|
||||
-- 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-
|
||||
-- chain, not the last.
|
||||
pattern DirOrSym :: File FileInfo -> File FileInfo
|
||||
pattern DirOrSym f <- (sdir -> (True, f))
|
||||
|
||||
-- |Matches on symlinks pointing to directories only.
|
||||
pattern DirSym :: File FileInfo -> File FileInfo
|
||||
pattern DirSym f <- (dirSym -> (True, f))
|
||||
|
||||
-- |Matches on any non-directory kind of files or symlinks pointing to
|
||||
@ -261,7 +261,6 @@ pattern DirSym f <- (dirSym -> (True, f))
|
||||
-- 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-
|
||||
-- chain, not the last.
|
||||
pattern FileLikeOrSym :: File FileInfo -> File FileInfo
|
||||
pattern FileLikeOrSym f <- (sfileLike -> (True, f))
|
||||
|
||||
|
||||
@ -300,10 +299,11 @@ instance Ord (File FileInfo) where
|
||||
|
||||
-- |Reads a file or directory Path into an `AnchoredFile`, filling the free
|
||||
-- variables via the given function.
|
||||
pathToFile :: (Path Abs -> IO a)
|
||||
-> Path Abs
|
||||
-> IO (File a)
|
||||
pathToFile ff p = do
|
||||
readFile :: (Path Abs -> IO a)
|
||||
-> Path Abs
|
||||
-> IO (File a)
|
||||
readFile ff p =
|
||||
handleDT p $ do
|
||||
fs <- PF.getSymbolicLinkStatus (P.toFilePath p)
|
||||
fv <- ff p
|
||||
constructFile fs fv p
|
||||
@ -313,12 +313,11 @@ pathToFile ff p = do
|
||||
-- symlink madness, we need to make sure we save the correct
|
||||
-- File
|
||||
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
|
||||
let sfp = (P.fromAbs . P.dirname $ p') </> x
|
||||
rsfp <- realpath sfp
|
||||
f <- pathToFile ff =<< P.parseAbs rsfp
|
||||
return $ Just f
|
||||
readFile ff =<< P.parseAbs rsfp
|
||||
return $ SymLink p' fv resolvedSyml x
|
||||
| PF.isDirectory fs = return $ Dir p' fv
|
||||
| PF.isRegularFile fs = return $ RegFile p' fv
|
||||
@ -326,7 +325,8 @@ pathToFile ff p = do
|
||||
| PF.isCharacterDevice fs = return $ CharDev p' fv
|
||||
| PF.isNamedPipe fs = return $ NamedPipe 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
|
||||
@ -336,10 +336,11 @@ readDirectoryContents :: (Path Abs -> IO a) -- ^ fills free a variable
|
||||
-> IO [File a]
|
||||
readDirectoryContents ff p = do
|
||||
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.
|
||||
getContents :: (Path Abs -> IO a)
|
||||
-> File FileInfo
|
||||
@ -352,12 +353,12 @@ getContents _ _ = return []
|
||||
|
||||
-- |Go up one directory in the filesystem hierarchy.
|
||||
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.
|
||||
goUp' :: Path Abs -> IO (File FileInfo)
|
||||
goUp' fp = pathToFile getFileInfo $ P.dirname fp
|
||||
goUp' fp = readFile getFileInfo $ P.dirname fp
|
||||
|
||||
|
||||
|
||||
@ -368,6 +369,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 ----
|
||||
@ -375,7 +398,11 @@ goUp' fp = pathToFile getFileInfo $ P.dirname fp
|
||||
|
||||
-- HELPER: a non-recursive comparison
|
||||
comparingConstr :: File FileInfo -> File FileInfo -> Ordering
|
||||
comparingConstr (Failed _ _) (DirOrSym _) = LT
|
||||
comparingConstr (Failed _ _) (FileLikeOrSym _) = LT
|
||||
comparingConstr (FileLikeOrSym _) (Failed _ _) = GT
|
||||
comparingConstr (FileLikeOrSym _) (DirOrSym _) = GT
|
||||
comparingConstr (DirOrSym _) (Failed _ _) = GT
|
||||
comparingConstr (DirOrSym _) (FileLikeOrSym _) = LT
|
||||
-- else compare on the names of constructors that are the same, without
|
||||
-- looking at the contents of Dir constructors:
|
||||
@ -434,6 +461,20 @@ isSocketC _ = False
|
||||
---- IO HELPERS: ----
|
||||
|
||||
|
||||
-- |Gets all filenames of the given directory. This excludes "." and "..".
|
||||
getDirsFiles :: Path Abs -- ^ dir to read
|
||||
-> IO [Path Abs]
|
||||
getDirsFiles p =
|
||||
P.withAbsPath p $ \fp ->
|
||||
rethrowErrnoAs [eACCES] (Can'tOpenDirectory fp)
|
||||
$ return
|
||||
. catMaybes
|
||||
. fmap (\x -> (P.</>) p <$> (parseMaybe . snd $ x))
|
||||
=<< getDirectoryContents fp
|
||||
where
|
||||
parseMaybe :: ByteString -> Maybe (Path Fn)
|
||||
parseMaybe = P.parseFn
|
||||
|
||||
|
||||
-- |Gets all file information.
|
||||
getFileInfo :: Path Abs -> IO FileInfo
|
||||
@ -457,6 +498,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: ----
|
||||
@ -467,25 +531,45 @@ getFileInfo fp = do
|
||||
--
|
||||
-- When called on a non-symlink, returns False.
|
||||
isBrokenSymlink :: File FileInfo -> Bool
|
||||
isBrokenSymlink (SymLink _ _ Nothing _) = True
|
||||
isBrokenSymlink (SymLink _ _ Failed{} _) = True
|
||||
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.
|
||||
packModTime :: File FileInfo
|
||||
-> String
|
||||
packModTime = epochToString . modificationTime . fvar
|
||||
packModTime = fromFreeVar $ epochToString . modificationTime
|
||||
|
||||
|
||||
-- |Pack the modification time into a string.
|
||||
packAccessTime :: File FileInfo
|
||||
-> String
|
||||
packAccessTime = epochToString . accessTime . fvar
|
||||
packAccessTime = fromFreeVar $ epochToString . accessTime
|
||||
|
||||
|
||||
epochToString :: EpochTime -> String
|
||||
@ -495,12 +579,12 @@ epochToString = show . posixSecondsToUTCTime . realToFrac
|
||||
-- |Pack the permissions into a string, similar to what "ls -l" does.
|
||||
packPermissions :: File FileInfo
|
||||
-> String
|
||||
packPermissions file = (pStr . fileMode) . fvar $ file
|
||||
packPermissions dt = fromFreeVar (pStr . fileMode) dt
|
||||
where
|
||||
pStr :: FileMode -> String
|
||||
pStr ffm = typeModeStr ++ ownerModeStr ++ groupModeStr ++ otherModeStr
|
||||
where
|
||||
typeModeStr = case file of
|
||||
typeModeStr = case dt of
|
||||
Dir {} -> "d"
|
||||
RegFile {} -> "-"
|
||||
SymLink {} -> "l"
|
||||
@ -508,6 +592,7 @@ packPermissions file = (pStr . fileMode) . fvar $ file
|
||||
CharDev {} -> "c"
|
||||
NamedPipe {} -> "p"
|
||||
Socket {} -> "s"
|
||||
_ -> "?"
|
||||
ownerModeStr = hasFmStr PF.ownerReadMode "r"
|
||||
++ hasFmStr PF.ownerWriteMode "w"
|
||||
++ hasFmStr PF.ownerExecuteMode "x"
|
||||
@ -532,6 +617,7 @@ packFileType file = case file of
|
||||
CharDev {} -> "Char Device"
|
||||
NamedPipe {} -> "Named Pipe"
|
||||
Socket {} -> "Socket"
|
||||
_ -> "Unknown"
|
||||
|
||||
|
||||
packLinkDestination :: File a -> Maybe ByteString
|
||||
@ -539,12 +625,3 @@ packLinkDestination file = case file of
|
||||
SymLink { rawdest = dest } -> Just dest
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
|
||||
|
||||
---- OTHER: ----
|
||||
|
||||
|
||||
getFPasStr :: File a -> String
|
||||
getFPasStr = toString . P.fromAbs . path
|
||||
|
||||
|
||||
@ -1,83 +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 #-}
|
||||
|
||||
|
||||
-- |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.UtilTypes where
|
||||
|
||||
|
||||
import Data.ByteString
|
||||
(
|
||||
ByteString
|
||||
)
|
||||
import HPath
|
||||
(
|
||||
Path
|
||||
, Abs
|
||||
, Rel
|
||||
)
|
||||
|
||||
|
||||
-- |Data type describing file operations.
|
||||
-- Useful to build up a list of operations or delay operations.
|
||||
data FileOperation = FCopy Copy
|
||||
| FMove Move
|
||||
| FDelete [Path Abs]
|
||||
| FOpen (Path Abs)
|
||||
| FExecute (Path Abs) [ByteString]
|
||||
| None
|
||||
|
||||
|
||||
-- |Data type describing partial or complete file copy operation.
|
||||
data Copy = PartialCopy [Path Abs] -- source files
|
||||
| Copy [Path Abs] -- source files
|
||||
(Path Abs) -- base destination directory
|
||||
|
||||
|
||||
-- |Data type describing partial or complete file move operation.
|
||||
data Move = PartialMove [Path Abs] -- source files
|
||||
| Move [Path Abs] -- source files
|
||||
(Path Abs) -- base destination directory
|
||||
|
||||
|
||||
-- |Collision modes that describe the behavior in case a file collision
|
||||
-- happens.
|
||||
data FCollisonMode = Strict -- ^ fail if the target already exists
|
||||
| Overwrite
|
||||
| OverwriteAll
|
||||
| Skip
|
||||
| Rename (Path Rel)
|
||||
|
||||
@ -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.
|
||||
--}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||
|
||||
|
||||
@ -66,7 +67,7 @@ instance GlibString BS.ByteString where
|
||||
newUTFStringLen = newUTFStringLen . toString
|
||||
genUTFOfs = genUTFOfs . toString
|
||||
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
|
||||
|
||||
@ -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.
|
||||
--}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||
|
||||
module Main where
|
||||
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Maybe
|
||||
(
|
||||
fromJust
|
||||
, fromMaybe
|
||||
)
|
||||
import Data.Word8
|
||||
import Graphics.UI.Gtk
|
||||
import qualified HPath as P
|
||||
import HSFM.FileSystem.FileType
|
||||
import HSFM.GUI.Gtk.Callbacks
|
||||
import HSFM.GUI.Gtk.Data
|
||||
import HSFM.GUI.Gtk.MyGUI
|
||||
import HSFM.GUI.Gtk.MyView
|
||||
import Prelude hiding(readFile)
|
||||
import Safe
|
||||
(
|
||||
headDef
|
||||
)
|
||||
import System.IO.Error
|
||||
(
|
||||
catchIOError
|
||||
)
|
||||
import qualified System.Posix.Env.ByteString as SPE
|
||||
|
||||
slash :: BS.ByteString
|
||||
slash = BS.singleton _slash
|
||||
|
||||
main :: IO ()
|
||||
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
|
||||
|
||||
args <- SPE.getArgs
|
||||
let mdir = fromMaybe (fromJust $ P.parseAbs "/")
|
||||
(P.parseAbs . headDef "/" $ args)
|
||||
|
||||
mygui <- createMyGUI
|
||||
_ <- newTab mygui (notebook1 mygui) createTreeView file (-1)
|
||||
_ <- newTab mygui (notebook2 mygui) createTreeView file (-1)
|
||||
_ <- newTab mygui createTreeView mdir
|
||||
|
||||
setGUICallbacks mygui
|
||||
|
||||
|
||||
@ -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.
|
||||
--}
|
||||
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||
|
||||
module HSFM.GUI.Gtk.Callbacks where
|
||||
@ -28,34 +28,18 @@ import Control.Concurrent.STM
|
||||
)
|
||||
import Control.Exception
|
||||
(
|
||||
throwIO
|
||||
throw
|
||||
)
|
||||
import Control.Monad
|
||||
(
|
||||
forM
|
||||
, forM_
|
||||
, join
|
||||
forM_
|
||||
, void
|
||||
, when
|
||||
)
|
||||
import Control.Monad.IfElse
|
||||
import Control.Monad.IO.Class
|
||||
(
|
||||
liftIO
|
||||
)
|
||||
import Control.Monad.Loops
|
||||
(
|
||||
iterateUntil
|
||||
)
|
||||
import Data.ByteString
|
||||
(
|
||||
ByteString
|
||||
)
|
||||
import Data.ByteString.UTF8
|
||||
(
|
||||
fromString
|
||||
, toString
|
||||
)
|
||||
import Data.Foldable
|
||||
(
|
||||
for_
|
||||
@ -63,45 +47,33 @@ import Data.Foldable
|
||||
import Graphics.UI.Gtk
|
||||
import qualified HPath as P
|
||||
import HPath
|
||||
(
|
||||
fromAbs
|
||||
, Abs
|
||||
, Path
|
||||
)
|
||||
import HPath.IO
|
||||
import HPath.IO.Errors
|
||||
(
|
||||
Abs
|
||||
, Path
|
||||
)
|
||||
import HSFM.FileSystem.Errors
|
||||
import HSFM.FileSystem.FileOperations
|
||||
import HSFM.FileSystem.FileType
|
||||
import HSFM.FileSystem.UtilTypes
|
||||
import HSFM.GUI.Gtk.Callbacks.Utils
|
||||
import HSFM.GUI.Gtk.Data
|
||||
import HSFM.GUI.Gtk.Dialogs
|
||||
import HSFM.GUI.Gtk.MyView
|
||||
import HSFM.GUI.Gtk.Plugins
|
||||
import HSFM.GUI.Gtk.Settings
|
||||
import HSFM.GUI.Gtk.Utils
|
||||
import HSFM.History
|
||||
import HSFM.Settings
|
||||
import HSFM.Utils.IO
|
||||
import Prelude hiding(readFile)
|
||||
import System.Glib.UTFString
|
||||
(
|
||||
glibToString
|
||||
)
|
||||
import System.Posix.Env.ByteString
|
||||
(
|
||||
getEnv
|
||||
)
|
||||
import qualified System.Posix.Process.ByteString as SPP
|
||||
import System.Posix.Types
|
||||
(
|
||||
ProcessID
|
||||
)
|
||||
import Control.Concurrent.MVar
|
||||
(
|
||||
putMVar
|
||||
, readMVar
|
||||
, takeMVar
|
||||
)
|
||||
import Paths_hsfm
|
||||
(
|
||||
getDataFileName
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
@ -120,18 +92,6 @@ import Paths_hsfm
|
||||
setGUICallbacks :: MyGUI -> IO ()
|
||||
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
|
||||
popStatusbar mygui
|
||||
writeTVarIO (operationBuffer mygui) None
|
||||
@ -147,8 +107,8 @@ setGUICallbacks mygui = do
|
||||
|
||||
-- key events
|
||||
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
|
||||
QuitModifier <- eventModifier
|
||||
QuitKey <- fmap glibToString eventKeyName
|
||||
[Control] <- eventModifier
|
||||
"q" <- fmap glibToString eventKeyName
|
||||
liftIO mainQuit
|
||||
|
||||
return ()
|
||||
@ -203,45 +163,7 @@ setViewCallbacks mygui myview = do
|
||||
commonGuiEvents fmv = do
|
||||
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
|
||||
_ <- 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
|
||||
_ <- upViewB myview `on` buttonActivated $
|
||||
upDir mygui myview
|
||||
@ -249,68 +171,69 @@ setViewCallbacks mygui myview = do
|
||||
goHome mygui myview
|
||||
_ <- refreshViewB myview `on` buttonActivated $ do
|
||||
cdir <- liftIO $ getCurrentDir myview
|
||||
refreshView mygui myview cdir
|
||||
refreshView' mygui myview cdir
|
||||
|
||||
-- key events
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
ShowHiddenModifier <- eventModifier
|
||||
ShowHiddenKey <- fmap glibToString eventKeyName
|
||||
[Control] <- eventModifier
|
||||
"h" <- fmap glibToString eventKeyName
|
||||
cdir <- liftIO $ getCurrentDir myview
|
||||
liftIO $ modifyTVarIO (settings mygui)
|
||||
(\x -> x { showHidden = not . showHidden $ x})
|
||||
>> refreshView mygui myview cdir
|
||||
>> refreshView' mygui myview cdir
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
UpDirModifier <- eventModifier
|
||||
UpDirKey <- fmap glibToString eventKeyName
|
||||
[Alt] <- eventModifier
|
||||
"Up" <- fmap glibToString eventKeyName
|
||||
liftIO $ upDir mygui myview
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
HistoryBackModifier <- eventModifier
|
||||
HistoryBackKey <- fmap glibToString eventKeyName
|
||||
liftIO $ void $ goHistoryBack mygui myview
|
||||
[Alt] <- eventModifier
|
||||
"Left" <- fmap glibToString eventKeyName
|
||||
liftIO $ goHistoryPrev mygui myview
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
HistoryForwardModifier <- eventModifier
|
||||
HistoryForwardKey <- fmap glibToString eventKeyName
|
||||
liftIO $ void $ goHistoryForward mygui myview
|
||||
[Alt] <- eventModifier
|
||||
"Right" <- fmap glibToString eventKeyName
|
||||
liftIO $ goHistoryNext mygui myview
|
||||
_ <- view `on` keyPressEvent $ tryEvent $ do
|
||||
DeleteModifier <- eventModifier
|
||||
DeleteKey <- fmap glibToString eventKeyName
|
||||
"Delete" <- fmap glibToString eventKeyName
|
||||
liftIO $ withItems mygui myview del
|
||||
_ <- view `on` keyPressEvent $ tryEvent $ do
|
||||
OpenModifier <- eventModifier
|
||||
OpenKey <- fmap glibToString eventKeyName
|
||||
[] <- eventModifier
|
||||
"Return" <- fmap glibToString eventKeyName
|
||||
liftIO $ withItems mygui myview open
|
||||
_ <- view `on` keyPressEvent $ tryEvent $ do
|
||||
CopyModifier <- eventModifier
|
||||
CopyKey <- fmap glibToString eventKeyName
|
||||
[Control] <- eventModifier
|
||||
"c" <- fmap glibToString eventKeyName
|
||||
liftIO $ withItems mygui myview copyInit
|
||||
_ <- view `on` keyPressEvent $ tryEvent $ do
|
||||
MoveModifier <- eventModifier
|
||||
MoveKey <- fmap glibToString eventKeyName
|
||||
[Control] <- eventModifier
|
||||
"x" <- fmap glibToString eventKeyName
|
||||
liftIO $ withItems mygui myview moveInit
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
PasteModifier <- eventModifier
|
||||
PasteKey <- fmap glibToString eventKeyName
|
||||
[Control] <- eventModifier
|
||||
"v" <- fmap glibToString eventKeyName
|
||||
liftIO $ operationFinal mygui myview Nothing
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
NewTabModifier <- eventModifier
|
||||
NewTabKey <- fmap glibToString eventKeyName
|
||||
liftIO $ void $ newTab' mygui myview
|
||||
[Control] <- eventModifier
|
||||
"t" <- fmap glibToString eventKeyName
|
||||
liftIO $ void $ do
|
||||
cwd <- getCurrentDir myview
|
||||
newTab mygui createTreeView (path cwd)
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
CloseTabModifier <- eventModifier
|
||||
CloseTabKey <- fmap glibToString eventKeyName
|
||||
[Control] <- eventModifier
|
||||
"w" <- fmap glibToString eventKeyName
|
||||
liftIO $ void $ closeTab mygui myview
|
||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||
OpenTerminalModifier <- eventModifier
|
||||
OpenTerminalKey <- fmap glibToString eventKeyName
|
||||
"F4" <- fmap glibToString eventKeyName
|
||||
liftIO $ void $ openTerminalHere myview
|
||||
|
||||
-- mouse button click
|
||||
-- righ-click
|
||||
_ <- view `on` buttonPressEvent $ do
|
||||
eb <- eventButton
|
||||
t <- eventTime
|
||||
case eb of
|
||||
RightButton -> do
|
||||
_ <- liftIO $ showPopup mygui myview t
|
||||
_ <- liftIO $ menuPopup (rcMenu . rcmenu $ myview)
|
||||
$ Just (RightButton, t)
|
||||
-- this is just to not screw with current selection
|
||||
-- on right-click
|
||||
-- TODO: this misbehaves under IconView
|
||||
@ -325,32 +248,42 @@ setViewCallbacks mygui myview = do
|
||||
return $ elem tp selectedTps
|
||||
-- no item under the cursor, pass on the signal
|
||||
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
|
||||
liftIO $ void $ goHistoryBack mygui myview
|
||||
liftIO $ goHistoryPrev mygui myview
|
||||
return False
|
||||
OtherButton 9 -> do
|
||||
liftIO $ void $ goHistoryForward mygui myview
|
||||
liftIO $ goHistoryNext mygui myview
|
||||
return False
|
||||
-- not right-click, so pass on the signal
|
||||
_ -> 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 ()
|
||||
|
||||
getPathAtPos fmv (x, y) =
|
||||
case fmv of
|
||||
FMTreeView treeView -> do
|
||||
@ -369,7 +302,8 @@ setViewCallbacks mygui myview = do
|
||||
openTerminalHere :: MyView -> IO ProcessID
|
||||
openTerminalHere myview = do
|
||||
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 +313,9 @@ openTerminalHere myview = do
|
||||
|
||||
-- |Closes the current tab, but only if there is more than one tab.
|
||||
closeTab :: MyGUI -> MyView -> IO ()
|
||||
closeTab _ myview = do
|
||||
n <- notebookGetNPages (notebook myview)
|
||||
when (n > 1) $ void $ destroyView 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 ()
|
||||
closeTab mygui myview = do
|
||||
n <- notebookGetNPages (notebook mygui)
|
||||
when (n > 1) $ void $ destroyView mygui myview
|
||||
|
||||
|
||||
|
||||
@ -407,21 +327,21 @@ del :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
del [item] _ _ = withErrorDialog $ do
|
||||
let cmsg = "Really delete \"" ++ getFPasStr item ++ "\"?"
|
||||
withConfirmationDialog cmsg
|
||||
$ easyDelete . path $ item
|
||||
$ easyDelete item
|
||||
-- this throws on the first error that occurs
|
||||
del items@(_:_) _ _ = withErrorDialog $ do
|
||||
let cmsg = "Really delete " ++ show (length items) ++ " files?"
|
||||
withConfirmationDialog cmsg
|
||||
$ forM_ items $ \item -> easyDelete . path $ item
|
||||
$ forM_ items $ \item -> easyDelete item
|
||||
del _ _ _ = withErrorDialog
|
||||
. ioError $ userError
|
||||
"Operation not supported on multiple files"
|
||||
. throw $ InvalidOperation
|
||||
"Operation not supported on multiple files"
|
||||
|
||||
|
||||
-- |Initializes a file move operation.
|
||||
moveInit :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
moveInit items@(_:_) mygui _ = do
|
||||
writeTVarIO (operationBuffer mygui) (FMove . PartialMove . map path $ items)
|
||||
writeTVarIO (operationBuffer mygui) (FMove . MP1 . map path $ items)
|
||||
let sbmsg = case items of
|
||||
(item:[]) -> "Move buffer: " ++ getFPasStr item
|
||||
_ -> "Move buffer: " ++ (show . length $ items)
|
||||
@ -429,13 +349,13 @@ moveInit items@(_:_) mygui _ = do
|
||||
popStatusbar mygui
|
||||
void $ pushStatusBar mygui sbmsg
|
||||
moveInit _ _ _ = withErrorDialog
|
||||
. ioError $ userError
|
||||
"No file selected!"
|
||||
. throw $ InvalidOperation
|
||||
"No file selected!"
|
||||
|
||||
-- |Supposed to be used with 'withRows'. Initializes a file copy operation.
|
||||
copyInit :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
copyInit items@(_:_) mygui _ = do
|
||||
writeTVarIO (operationBuffer mygui) (FCopy . PartialCopy . map path $ items)
|
||||
writeTVarIO (operationBuffer mygui) (FCopy . CP1 . map path $ items)
|
||||
let sbmsg = case items of
|
||||
(item:[]) -> "Copy buffer: " ++ getFPasStr item
|
||||
_ -> "Copy buffer: " ++ (show . length $ items)
|
||||
@ -443,8 +363,8 @@ copyInit items@(_:_) mygui _ = do
|
||||
popStatusbar mygui
|
||||
void $ pushStatusBar mygui sbmsg
|
||||
copyInit _ _ _ = withErrorDialog
|
||||
. ioError $ userError
|
||||
"No file selected!"
|
||||
. throw $ InvalidOperation
|
||||
"No file selected!"
|
||||
|
||||
|
||||
-- |Finalizes a file operation, such as copy or move.
|
||||
@ -455,61 +375,62 @@ operationFinal mygui myview mitem = withErrorDialog $ do
|
||||
Nothing -> path <$> getCurrentDir myview
|
||||
Just x -> return $ path x
|
||||
case op of
|
||||
FMove (PartialMove s) -> do
|
||||
FMove (MP1 s) -> do
|
||||
let cmsg = "Really move " ++ imsg s
|
||||
++ " to \"" ++ toString (P.fromAbs cdir)
|
||||
++ " to \"" ++ P.fpToString (P.fromAbs cdir)
|
||||
++ "\"?"
|
||||
withConfirmationDialog cmsg $ doFileOperation (FMove $ Move s cdir)
|
||||
popStatusbar mygui
|
||||
writeTVarIO (operationBuffer mygui) None
|
||||
FCopy (PartialCopy s) -> do
|
||||
withConfirmationDialog cmsg . withCopyModeDialog
|
||||
$ \cm -> do
|
||||
void $ runFileOp (FMove . MC s cdir $ cm)
|
||||
popStatusbar mygui
|
||||
writeTVarIO (operationBuffer mygui) None
|
||||
FCopy (CP1 s) -> do
|
||||
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 . withCopyModeDialog
|
||||
$ \cm -> void $ runFileOp (FCopy . CC s cdir $ cm)
|
||||
_ -> return ()
|
||||
where
|
||||
imsg s = case s of
|
||||
(item:[]) -> "\"" ++ toString (P.fromAbs item) ++ "\""
|
||||
(item:[]) -> "\"" ++ P.fpToString (P.fromAbs item) ++ "\""
|
||||
items -> (show . length $ items) ++ " items"
|
||||
|
||||
|
||||
-- |Create a new file.
|
||||
newFile :: MyGUI -> MyView -> IO ()
|
||||
newFile _ myview = withErrorDialog $ do
|
||||
mfn <- textInputDialog "Enter file name" ("" :: String)
|
||||
let pmfn = P.parseRel =<< fromString <$> mfn
|
||||
mfn <- textInputDialog "Enter file name"
|
||||
let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
|
||||
for_ pmfn $ \fn -> do
|
||||
cdir <- getCurrentDir myview
|
||||
createRegularFile newFilePerms (path cdir P.</> fn)
|
||||
createFile cdir fn
|
||||
|
||||
|
||||
-- |Create a new directory.
|
||||
newDir :: MyGUI -> MyView -> IO ()
|
||||
newDir _ myview = withErrorDialog $ do
|
||||
mfn <- textInputDialog "Enter directory name" ("" :: String)
|
||||
let pmfn = P.parseRel =<< fromString <$> mfn
|
||||
mfn <- textInputDialog "Enter directory name"
|
||||
let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
|
||||
for_ pmfn $ \fn -> do
|
||||
cdir <- getCurrentDir myview
|
||||
createDir newDirPerms (path cdir P.</> fn)
|
||||
createDir cdir fn
|
||||
|
||||
|
||||
renameF :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
renameF [item] _ _ = withErrorDialog $ do
|
||||
iname <- P.fromRel <$> (P.basename $ path item)
|
||||
mfn <- textInputDialog "Enter new file name" (iname :: ByteString)
|
||||
let pmfn = P.parseRel =<< fromString <$> mfn
|
||||
mfn <- textInputDialog "Enter new file name"
|
||||
let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
|
||||
for_ pmfn $ \fn -> do
|
||||
let cmsg = "Really rename \"" ++ getFPasStr item
|
||||
++ "\"" ++ " to \""
|
||||
++ toString (P.fromAbs $ (P.dirname . path $ item)
|
||||
++ P.fpToString (P.fromAbs $ (P.dirname . path $ item)
|
||||
P.</> fn) ++ "\"?"
|
||||
withConfirmationDialog cmsg $
|
||||
HPath.IO.renameFile (path item)
|
||||
((P.dirname $ path item) P.</> fn)
|
||||
HSFM.FileSystem.FileOperations.renameFile item fn
|
||||
renameF _ _ _ = withErrorDialog
|
||||
. ioError $ userError
|
||||
"Operation not supported on multiple files"
|
||||
. throw $ InvalidOperation
|
||||
"Operation not supported on multiple files"
|
||||
|
||||
|
||||
|
||||
@ -526,24 +447,24 @@ urlGoTo mygui myview = withErrorDialog $ do
|
||||
fp <- entryGetText (urlBar myview)
|
||||
forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' ->
|
||||
whenM (canOpenDirectory fp')
|
||||
(goDir True mygui myview =<< (pathToFile getFileInfo $ fp'))
|
||||
(goDir mygui myview =<< (readFile getFileInfo $ fp'))
|
||||
|
||||
|
||||
goHome :: MyGUI -> MyView -> IO ()
|
||||
goHome mygui myview = withErrorDialog $ do
|
||||
homedir <- home
|
||||
forM_ (P.parseAbs homedir :: Maybe (Path Abs)) $ \fp' ->
|
||||
mhomedir <- getEnv "HOME"
|
||||
forM_ (P.parseAbs =<< mhomedir :: Maybe (Path Abs)) $ \fp' ->
|
||||
whenM (canOpenDirectory fp')
|
||||
(goDir True mygui myview =<< (pathToFile getFileInfo $ fp'))
|
||||
(goDir mygui myview =<< (readFile getFileInfo $ fp'))
|
||||
|
||||
|
||||
-- |Execute a given file.
|
||||
execute :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
execute [item] _ _ = withErrorDialog $
|
||||
void $ executeFile (path item) []
|
||||
void $ executeFile item []
|
||||
execute _ _ _ = withErrorDialog
|
||||
. ioError $ userError
|
||||
"Operation not supported on multiple files"
|
||||
. throw $ InvalidOperation
|
||||
"Operation not supported on multiple files"
|
||||
|
||||
|
||||
-- |Supposed to be used with 'withRows'. Opens a file or directory.
|
||||
@ -551,15 +472,16 @@ open :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
open [item] mygui myview = withErrorDialog $
|
||||
case item of
|
||||
DirOrSym r -> do
|
||||
nv <- pathToFile getFileInfo $ path r
|
||||
goDir True mygui myview nv
|
||||
nv <- readFile getFileInfo $ path r
|
||||
goDir mygui myview nv
|
||||
r ->
|
||||
void $ openFile . path $ r
|
||||
open items mygui myview = do
|
||||
let dirs = filter (fst . sdir) items
|
||||
files = filter (fst . sfileLike) items
|
||||
forM_ dirs (withErrorDialog . opeInNewTab mygui myview)
|
||||
forM_ files (withErrorDialog . openFile . path)
|
||||
void $ openFile r
|
||||
-- this throws on the first error that occurs
|
||||
open (FileLikeList fs) _ _ = withErrorDialog $
|
||||
forM_ fs $ \f -> void $ openFile f
|
||||
open _ _ _ = withErrorDialog
|
||||
. throw $ InvalidOperation
|
||||
"Operation not supported on multiple files"
|
||||
|
||||
|
||||
-- |Go up one directory and visualize it in the treeView.
|
||||
@ -567,162 +489,42 @@ upDir :: MyGUI -> MyView -> IO ()
|
||||
upDir mygui myview = withErrorDialog $ do
|
||||
cdir <- getCurrentDir myview
|
||||
nv <- goUp cdir
|
||||
goDir True mygui myview nv
|
||||
goDir mygui myview nv
|
||||
|
||||
|
||||
|
||||
|
||||
---- HISTORY CALLBACKS ----
|
||||
-- |Helper that is invoked for any directory change operations.
|
||||
goDir :: MyGUI -> MyView -> Item -> IO ()
|
||||
goDir mygui myview item = do
|
||||
cdir <- getCurrentDir myview
|
||||
modifyTVarIO (history myview)
|
||||
(\(p, _) -> (path cdir `addHistory` p, []))
|
||||
refreshView' mygui myview item
|
||||
|
||||
|
||||
-- |Go "back" in the history.
|
||||
goHistoryBack :: MyGUI -> MyView -> IO (Path Abs)
|
||||
goHistoryBack mygui myview = do
|
||||
hs <- takeMVar (history myview)
|
||||
let nhs = historyBack hs
|
||||
putMVar (history myview) nhs
|
||||
nv <- pathToFile getFileInfo $ currentDir nhs
|
||||
goDir False mygui myview nv
|
||||
return $ currentDir nhs
|
||||
goHistoryPrev :: MyGUI -> MyView -> IO ()
|
||||
goHistoryPrev mygui myview = do
|
||||
hs <- readTVarIO (history myview)
|
||||
case hs of
|
||||
([], _) -> return ()
|
||||
(x:xs, _) -> do
|
||||
cdir <- getCurrentDir myview
|
||||
nv <- readFile getFileInfo $ x
|
||||
modifyTVarIO (history myview)
|
||||
(\(_, n) -> (xs, path cdir `addHistory` n))
|
||||
refreshView' mygui myview nv
|
||||
|
||||
|
||||
-- |Go "forward" in the history.
|
||||
goHistoryForward :: MyGUI -> MyView -> IO (Path Abs)
|
||||
goHistoryForward mygui myview = do
|
||||
hs <- takeMVar (history myview)
|
||||
let nhs = historyForward hs
|
||||
putMVar (history myview) nhs
|
||||
nv <- pathToFile getFileInfo $ currentDir nhs
|
||||
goDir False mygui myview nv
|
||||
return $ currentDir nhs
|
||||
|
||||
|
||||
-- |Show backwards history in a drop-down menu, depending on the input.
|
||||
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 {..}
|
||||
-- |Go "forth" in the history.
|
||||
goHistoryNext :: MyGUI -> MyView -> IO ()
|
||||
goHistoryNext mygui myview = do
|
||||
hs <- readTVarIO (history myview)
|
||||
case hs of
|
||||
(_, []) -> return ()
|
||||
(_, x:xs) -> do
|
||||
cdir <- getCurrentDir myview
|
||||
nv <- readFile getFileInfo $ x
|
||||
modifyTVarIO (history myview)
|
||||
(\(p, _) -> (path cdir `addHistory` p, xs))
|
||||
refreshView' mygui myview nv
|
||||
|
||||
|
||||
@ -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 ScopedTypeVariables #-}
|
||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||
|
||||
module HSFM.GUI.Gtk.Callbacks.Utils where
|
||||
|
||||
|
||||
|
||||
import Control.Monad
|
||||
(
|
||||
forM_
|
||||
, when
|
||||
)
|
||||
import Data.Foldable
|
||||
(
|
||||
for_
|
||||
)
|
||||
import Data.Maybe
|
||||
(
|
||||
fromJust
|
||||
)
|
||||
import GHC.IO.Exception
|
||||
(
|
||||
IOErrorType(..)
|
||||
)
|
||||
import Graphics.UI.Gtk
|
||||
import qualified HPath as P
|
||||
import HPath.IO
|
||||
import HPath.IO.Errors
|
||||
import HSFM.FileSystem.FileType
|
||||
import qualified HSFM.FileSystem.UtilTypes as UT
|
||||
import HSFM.GUI.Gtk.Data
|
||||
import HSFM.GUI.Gtk.Dialogs
|
||||
import HSFM.GUI.Gtk.MyView
|
||||
import HSFM.History
|
||||
import Prelude hiding(readFile)
|
||||
import Control.Concurrent.MVar
|
||||
(
|
||||
putMVar
|
||||
, tryTakeMVar
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
-- |Carries out a file operation with the appropriate error handling
|
||||
-- allowing the user to react to various exceptions with further input.
|
||||
doFileOperation :: UT.FileOperation -> IO ()
|
||||
doFileOperation (UT.FCopy (UT.Copy (f':fs') to)) =
|
||||
_doFileOperation (f':fs') to (\p1 p2 cm -> easyCopy p1 p2 cm FailEarly)
|
||||
$ doFileOperation (UT.FCopy $ UT.Copy fs' to)
|
||||
doFileOperation (UT.FMove (UT.Move (f':fs') to)) =
|
||||
_doFileOperation (f':fs') to moveFile
|
||||
$ doFileOperation (UT.FMove $ UT.Move fs' to)
|
||||
doFileOperation _ = return ()
|
||||
|
||||
|
||||
_doFileOperation :: [P.Path b1]
|
||||
-> P.Path P.Abs
|
||||
-> (P.Path b1 -> P.Path P.Abs -> CopyMode -> IO b)
|
||||
-> IO ()
|
||||
-> IO ()
|
||||
_doFileOperation [] _ _ _ = return ()
|
||||
_doFileOperation (f:fs) to mc rest = do
|
||||
toname <- P.basename f
|
||||
let topath = to P.</> toname
|
||||
reactOnError (mc f topath Strict >> rest)
|
||||
-- TODO: how safe is 'AlreadyExists' here?
|
||||
[(AlreadyExists , collisionAction fileCollisionDialog topath)]
|
||||
[(SameFile{} , collisionAction renameDialog topath)]
|
||||
where
|
||||
collisionAction diag topath = do
|
||||
mcm <- diag . P.fromAbs $ topath
|
||||
forM_ mcm $ \cm -> case cm of
|
||||
UT.Overwrite -> mc f topath Overwrite >> rest
|
||||
UT.OverwriteAll -> forM_ (f:fs) $ \x -> do
|
||||
toname' <- P.basename x
|
||||
mc x (to P.</> toname') Overwrite
|
||||
UT.Skip -> rest
|
||||
UT.Rename newn -> mc f (to P.</> newn) Strict >> rest
|
||||
_ -> return ()
|
||||
|
||||
|
||||
-- |Helper that is invoked for any directory change operations.
|
||||
goDir :: Bool -- ^ whether to update the history
|
||||
-> MyGUI
|
||||
-> MyView
|
||||
-> Item
|
||||
-> IO ()
|
||||
goDir bhis mygui myview item = do
|
||||
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)
|
||||
|
||||
@ -30,10 +30,14 @@ import Control.Concurrent.STM
|
||||
TVar
|
||||
)
|
||||
import Graphics.UI.Gtk hiding (MenuBar)
|
||||
import HPath
|
||||
(
|
||||
Abs
|
||||
, Path
|
||||
)
|
||||
import HSFM.FileSystem.FileOperations
|
||||
import HSFM.FileSystem.FileType
|
||||
import HSFM.FileSystem.UtilTypes
|
||||
import HSFM.History
|
||||
import System.INotify
|
||||
import System.INotify.ByteString
|
||||
(
|
||||
INotify
|
||||
)
|
||||
@ -57,14 +61,7 @@ data MyGUI = MkMyGUI {
|
||||
, menubar :: !MenuBar
|
||||
, statusBar :: !Statusbar
|
||||
, clearStatusBar :: !Button
|
||||
|
||||
, notebook1 :: !Notebook
|
||||
, leftNbBtn :: !ToggleButton
|
||||
, leftNbIcon :: !Image
|
||||
|
||||
, notebook2 :: !Notebook
|
||||
, rightNbBtn :: !ToggleButton
|
||||
, rightNbIcon :: !Image
|
||||
, notebook :: !Notebook
|
||||
|
||||
-- other
|
||||
, fprop :: !FilePropertyGrid
|
||||
@ -83,18 +80,16 @@ data MyView = MkMyView {
|
||||
, sortedModel :: !(TVar (TypedTreeModelSort Item))
|
||||
, filteredModel :: !(TVar (TypedTreeModelFilter Item))
|
||||
, inotify :: !(MVar INotify)
|
||||
, notebook :: !Notebook -- current notebook
|
||||
|
||||
-- the first part of the tuple represents the "go back"
|
||||
-- the second part the "go forth" in the history
|
||||
, history :: !(MVar BrowsingHistory)
|
||||
, history :: !(TVar ([Path Abs], [Path Abs]))
|
||||
|
||||
-- sub-widgets
|
||||
, scroll :: !ScrolledWindow
|
||||
, viewBox :: !Box
|
||||
, backViewB :: !Button
|
||||
, rcmenu :: !RightClickMenu
|
||||
, upViewB :: !Button
|
||||
, forwardViewB :: !Button
|
||||
, homeViewB :: !Button
|
||||
, refreshViewB :: !Button
|
||||
, urlBar :: !Entry
|
||||
@ -112,8 +107,6 @@ data RightClickMenu = MkRightClickMenu {
|
||||
, rcFileExecute :: !ImageMenuItem
|
||||
, rcFileNewRegFile :: !ImageMenuItem
|
||||
, rcFileNewDir :: !ImageMenuItem
|
||||
, rcFileNewTab :: !ImageMenuItem
|
||||
, rcFileNewTerm :: !ImageMenuItem
|
||||
, rcFileCut :: !ImageMenuItem
|
||||
, rcFileCopy :: !ImageMenuItem
|
||||
, rcFileRename :: !ImageMenuItem
|
||||
|
||||
@ -16,22 +16,18 @@ along with this program; if not, write to the Free Software
|
||||
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
||||
--}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||
|
||||
module HSFM.GUI.Gtk.Dialogs where
|
||||
|
||||
|
||||
import Codec.Binary.UTF8.String
|
||||
(
|
||||
decodeString
|
||||
)
|
||||
import Control.Exception
|
||||
(
|
||||
catches
|
||||
catch
|
||||
, displayException
|
||||
, throwIO
|
||||
, throw
|
||||
, IOException
|
||||
, catches
|
||||
, Handler(..)
|
||||
)
|
||||
import Control.Monad
|
||||
@ -40,48 +36,24 @@ import Control.Monad
|
||||
, when
|
||||
, void
|
||||
)
|
||||
import Data.ByteString
|
||||
(
|
||||
ByteString
|
||||
)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.ByteString.UTF8
|
||||
(
|
||||
fromString
|
||||
)
|
||||
import Distribution.Package
|
||||
(
|
||||
PackageIdentifier(..)
|
||||
, packageVersion
|
||||
, unPackageName
|
||||
)
|
||||
#if MIN_VERSION_Cabal(2,0,0)
|
||||
import Distribution.Version
|
||||
(
|
||||
showVersion
|
||||
)
|
||||
#else
|
||||
import Data.Version
|
||||
(
|
||||
showVersion
|
||||
)
|
||||
#endif
|
||||
import Distribution.Package
|
||||
(
|
||||
PackageIdentifier(..)
|
||||
, PackageName(..)
|
||||
)
|
||||
import Distribution.PackageDescription
|
||||
(
|
||||
GenericPackageDescription(..)
|
||||
, PackageDescription(..)
|
||||
)
|
||||
#if MIN_VERSION_Cabal(2,2,0)
|
||||
import Distribution.PackageDescription.Parsec
|
||||
#else
|
||||
import Distribution.PackageDescription.Parse
|
||||
#endif
|
||||
(
|
||||
#if MIN_VERSION_Cabal(2,0,0)
|
||||
readGenericPackageDescription,
|
||||
#else
|
||||
readPackageDescription,
|
||||
#endif
|
||||
readPackageDescription
|
||||
)
|
||||
import Distribution.Verbosity
|
||||
(
|
||||
@ -89,9 +61,9 @@ import Distribution.Verbosity
|
||||
)
|
||||
import Graphics.UI.Gtk
|
||||
import qualified HPath as P
|
||||
import HPath.IO.Errors
|
||||
import HSFM.FileSystem.Errors
|
||||
import HSFM.FileSystem.FileOperations
|
||||
import HSFM.FileSystem.FileType
|
||||
import HSFM.FileSystem.UtilTypes
|
||||
import HSFM.GUI.Glib.GlibString()
|
||||
import HSFM.GUI.Gtk.Data
|
||||
import HSFM.GUI.Gtk.Errors
|
||||
@ -99,17 +71,6 @@ import Paths_hsfm
|
||||
(
|
||||
getDataFileName
|
||||
)
|
||||
import System.Glib.UTFString
|
||||
(
|
||||
GlibString
|
||||
)
|
||||
import System.Posix.FilePath
|
||||
(
|
||||
takeFileName
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -147,58 +108,76 @@ showConfirmationDialog str = do
|
||||
_ -> return False
|
||||
|
||||
|
||||
fileCollisionDialog :: ByteString -> IO (Maybe FCollisonMode)
|
||||
fileCollisionDialog t = do
|
||||
-- |Asks the user which directory copy mode he wants via dialog popup
|
||||
-- and returns 'DirCopyMode'. Default is always Strict, so this allows
|
||||
-- switching to Merge/Replace/Rename.
|
||||
showCopyModeDialog :: IO (Maybe CopyMode)
|
||||
showCopyModeDialog = do
|
||||
chooserDialog <- messageDialogNew Nothing
|
||||
[DialogDestroyWithParent]
|
||||
MessageQuestion
|
||||
ButtonsNone
|
||||
(fromString "Target \"" `BS.append`
|
||||
t `BS.append`
|
||||
fromString "\" exists, how to proceed?")
|
||||
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0)
|
||||
_ <- dialogAddButton chooserDialog "Overwrite" (ResponseUser 1)
|
||||
_ <- dialogAddButton chooserDialog "Overwrite all" (ResponseUser 2)
|
||||
_ <- dialogAddButton chooserDialog "Skip" (ResponseUser 3)
|
||||
_ <- dialogAddButton chooserDialog "Rename" (ResponseUser 4)
|
||||
"Target exists, how to proceed?"
|
||||
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0)
|
||||
_ <- dialogAddButton chooserDialog "Merge" (ResponseUser 1)
|
||||
_ <- dialogAddButton chooserDialog "Replace" (ResponseUser 2)
|
||||
_ <- dialogAddButton chooserDialog "Rename" (ResponseUser 3)
|
||||
rID <- dialogRun chooserDialog
|
||||
widgetDestroy chooserDialog
|
||||
case rID of
|
||||
ResponseUser 0 -> return Nothing
|
||||
ResponseUser 1 -> return (Just Overwrite)
|
||||
ResponseUser 2 -> return (Just OverwriteAll)
|
||||
ResponseUser 3 -> return (Just Skip)
|
||||
ResponseUser 4 -> do
|
||||
mfn <- textInputDialog (fromString "Enter new name") (takeFileName t)
|
||||
ResponseUser 1 -> return (Just Merge)
|
||||
ResponseUser 2 -> return (Just Replace)
|
||||
ResponseUser 3 -> do
|
||||
mfn <- textInputDialog "Enter new name"
|
||||
forM mfn $ \fn -> do
|
||||
pfn <- P.parseRel (fromString fn)
|
||||
pfn <- P.parseFn (P.userStringToFP fn)
|
||||
return $ Rename pfn
|
||||
_ -> throwIO UnknownDialogButton
|
||||
_ -> throw UnknownDialogButton
|
||||
|
||||
|
||||
renameDialog :: ByteString -> IO (Maybe FCollisonMode)
|
||||
renameDialog t = do
|
||||
-- |Stipped version of `showCopyModeDialog` that only allows cancelling
|
||||
-- or Renaming.
|
||||
showRenameDialog :: IO (Maybe CopyMode)
|
||||
showRenameDialog = do
|
||||
chooserDialog <- messageDialogNew Nothing
|
||||
[DialogDestroyWithParent]
|
||||
MessageQuestion
|
||||
ButtonsNone
|
||||
(fromString "Target \"" `BS.append`
|
||||
t `BS.append`
|
||||
fromString "\" exists, how to proceed?")
|
||||
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0)
|
||||
_ <- dialogAddButton chooserDialog "Skip" (ResponseUser 1)
|
||||
_ <- dialogAddButton chooserDialog "Rename" (ResponseUser 2)
|
||||
"Target exists, how to proceed?"
|
||||
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0)
|
||||
_ <- dialogAddButton chooserDialog "Rename" (ResponseUser 1)
|
||||
rID <- dialogRun chooserDialog
|
||||
widgetDestroy chooserDialog
|
||||
case rID of
|
||||
ResponseUser 0 -> return Nothing
|
||||
ResponseUser 1 -> return (Just Skip)
|
||||
ResponseUser 2 -> do
|
||||
mfn <- textInputDialog (fromString "Enter new name") (takeFileName t)
|
||||
ResponseUser 1 -> do
|
||||
mfn <- textInputDialog "Enter new name"
|
||||
forM mfn $ \fn -> do
|
||||
pfn <- P.parseRel (fromString fn)
|
||||
pfn <- P.parseFn (P.userStringToFP fn)
|
||||
return $ Rename pfn
|
||||
_ -> throwIO UnknownDialogButton
|
||||
_ -> throw UnknownDialogButton
|
||||
|
||||
|
||||
-- |Attempts to run the given function with the `Strict` copy mode.
|
||||
-- If that raises a `FileDoesExist` or `DirDoesExist`, then it prompts
|
||||
-- the user for action via `showCopyModeDialog` and then carries out
|
||||
-- the given function again.
|
||||
withCopyModeDialog :: (CopyMode -> IO ()) -> IO ()
|
||||
withCopyModeDialog fa =
|
||||
catch (fa Strict) $ \e ->
|
||||
case e of
|
||||
FileDoesExist _ -> doIt showCopyModeDialog
|
||||
DirDoesExist _ -> doIt showCopyModeDialog
|
||||
SameFile _ _ -> doIt showRenameDialog
|
||||
e' -> throw e'
|
||||
where
|
||||
doIt getCm = do
|
||||
mcm <- getCm
|
||||
case mcm of
|
||||
(Just Strict) -> return () -- don't try again
|
||||
(Just cm) -> fa cm
|
||||
Nothing -> return ()
|
||||
|
||||
|
||||
-- |Shows the about dialog from the help menu.
|
||||
@ -208,16 +187,12 @@ showAboutDialog = do
|
||||
lstr <- Prelude.readFile =<< getDataFileName "LICENSE"
|
||||
hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png"
|
||||
pdesc <- fmap packageDescription
|
||||
#if MIN_VERSION_Cabal(2,0,0)
|
||||
(readGenericPackageDescription silent
|
||||
#else
|
||||
(readPackageDescription silent
|
||||
#endif
|
||||
=<< getDataFileName "hsfm.cabal")
|
||||
set ad
|
||||
[ aboutDialogProgramName := (unPackageName . pkgName . package) pdesc
|
||||
, aboutDialogName := (unPackageName . pkgName . package) pdesc
|
||||
, aboutDialogVersion := (showVersion . packageVersion . package) pdesc
|
||||
, aboutDialogVersion := (showVersion . pkgVersion . package) pdesc
|
||||
, aboutDialogCopyright := copyright pdesc
|
||||
, aboutDialogComments := description pdesc
|
||||
, aboutDialogLicense := Just lstr
|
||||
@ -244,28 +219,22 @@ withErrorDialog :: IO a -> IO ()
|
||||
withErrorDialog io =
|
||||
catches (void io)
|
||||
[ Handler (\e -> showErrorDialog
|
||||
. decodeString
|
||||
. displayException
|
||||
$ (e :: IOException))
|
||||
$ displayException (e :: IOException))
|
||||
, Handler (\e -> showErrorDialog
|
||||
$ displayException (e :: HPathIOException))
|
||||
$ displayException (e :: FmIOException))
|
||||
]
|
||||
|
||||
|
||||
-- |Asks the user which directory copy mode he wants via dialog popup
|
||||
-- and returns 'DirCopyMode'.
|
||||
textInputDialog :: (GlibString s1, GlibString s2)
|
||||
=> s1 -- ^ window title
|
||||
-> s2 -- ^ initial text in input widget
|
||||
-> IO (Maybe String)
|
||||
textInputDialog title inittext = do
|
||||
textInputDialog :: String -> IO (Maybe String)
|
||||
textInputDialog title = do
|
||||
chooserDialog <- messageDialogNew Nothing
|
||||
[DialogDestroyWithParent]
|
||||
MessageQuestion
|
||||
ButtonsNone
|
||||
title
|
||||
entry <- entryNew
|
||||
entrySetText entry inittext
|
||||
cbox <- dialogGetActionArea chooserDialog
|
||||
_ <- dialogAddButton chooserDialog "Ok" (ResponseUser 0)
|
||||
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 1)
|
||||
@ -276,7 +245,7 @@ textInputDialog title inittext = do
|
||||
-- TODO: make this more safe
|
||||
ResponseUser 0 -> Just <$> entryGetText entry
|
||||
ResponseUser 1 -> return Nothing
|
||||
_ -> throwIO UnknownDialogButton
|
||||
_ -> throw UnknownDialogButton
|
||||
widgetDestroy chooserDialog
|
||||
return ret
|
||||
|
||||
@ -295,7 +264,7 @@ showFilePropertyDialog [item] mygui _ = do
|
||||
entrySetText (fpropFnEntry fprop') (maybe BS.empty P.fromRel
|
||||
$ P.basename . 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 (fpropAcEntry fprop') (packAccessTime item)
|
||||
entrySetText (fpropFTEntry fprop') (packFileType item)
|
||||
|
||||
@ -27,7 +27,7 @@ import Control.Concurrent.STM
|
||||
newTVarIO
|
||||
)
|
||||
import Graphics.UI.Gtk
|
||||
import HSFM.FileSystem.UtilTypes
|
||||
import HSFM.FileSystem.FileOperations
|
||||
import HSFM.GUI.Gtk.Data
|
||||
import Paths_hsfm
|
||||
(
|
||||
@ -45,6 +45,7 @@ import Paths_hsfm
|
||||
-- |Set up the GUI. This only creates the permanent widgets.
|
||||
createMyGUI :: IO MyGUI
|
||||
createMyGUI = do
|
||||
|
||||
let settings' = MkFMSettings False True 24
|
||||
settings <- newTVarIO settings'
|
||||
operationBuffer <- newTVarIO None
|
||||
@ -81,32 +82,8 @@ createMyGUI = do
|
||||
"fpropPermEntry"
|
||||
fpropLDEntry <- builderGetObject builder castToEntry
|
||||
"fpropLDEntry"
|
||||
notebook1 <- builderGetObject builder castToNotebook
|
||||
"notebook1"
|
||||
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
|
||||
notebook <- builderGetObject builder castToNotebook
|
||||
"notebook"
|
||||
|
||||
-- construct the gui object
|
||||
let menubar = MkMenuBar {..}
|
||||
|
||||
@ -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.
|
||||
--}
|
||||
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||
|
||||
|
||||
module HSFM.GUI.Gtk.MyView where
|
||||
@ -33,15 +33,10 @@ import Control.Concurrent.STM
|
||||
newTVarIO
|
||||
, readTVarIO
|
||||
)
|
||||
import Control.Monad
|
||||
import Control.Exception
|
||||
(
|
||||
unless
|
||||
, void
|
||||
, when
|
||||
)
|
||||
import Control.Monad.IO.Class
|
||||
(
|
||||
liftIO
|
||||
try
|
||||
, SomeException
|
||||
)
|
||||
import Data.Foldable
|
||||
(
|
||||
@ -52,98 +47,57 @@ import Data.Maybe
|
||||
catMaybes
|
||||
, fromJust
|
||||
)
|
||||
import Data.String
|
||||
import HSFM.FileSystem.Errors
|
||||
(
|
||||
fromString
|
||||
canOpenDirectory
|
||||
)
|
||||
import Graphics.UI.Gtk
|
||||
import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setViewCallbacks)
|
||||
import HPath
|
||||
(
|
||||
Path
|
||||
, Abs
|
||||
)
|
||||
import qualified HPath as P
|
||||
import HSFM.FileSystem.FileType
|
||||
import HSFM.GUI.Glib.GlibString()
|
||||
import HSFM.GUI.Gtk.Data
|
||||
import HSFM.GUI.Gtk.Icons
|
||||
import HSFM.GUI.Gtk.Utils
|
||||
import HSFM.History
|
||||
import HSFM.Utils.IO
|
||||
import Paths_hsfm
|
||||
(
|
||||
getDataFileName
|
||||
)
|
||||
import Prelude hiding(readFile)
|
||||
import System.INotify
|
||||
import System.INotify.ByteString
|
||||
(
|
||||
addWatch
|
||||
, initINotify
|
||||
, killINotify
|
||||
, 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.
|
||||
newTab :: MyGUI -> Notebook -> IO FMView -> Item -> Int -> IO MyView
|
||||
newTab mygui nb iofmv item pos = do
|
||||
|
||||
|
||||
-- create eventbox with label
|
||||
label <- labelNewWithMnemonic
|
||||
(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
|
||||
|
||||
newTab :: MyGUI -> IO FMView -> Path Abs -> IO MyView
|
||||
newTab mygui iofmv path = do
|
||||
myview <- createMyView mygui iofmv
|
||||
_ <- notebookAppendPage (notebook mygui) (viewBox myview)
|
||||
(maybe (P.fromAbs path) P.fromRel $ P.basename path)
|
||||
refreshView mygui myview (Just path)
|
||||
return myview
|
||||
|
||||
|
||||
-- |Constructs the initial MyView object with a few dummy models.
|
||||
-- It also initializes the callbacks.
|
||||
createMyView :: MyGUI
|
||||
-> Notebook
|
||||
-> IO FMView
|
||||
-> IO MyView
|
||||
createMyView mygui nb iofmv = do
|
||||
createMyView mygui iofmv = do
|
||||
inotify <- newEmptyMVar
|
||||
history <- newEmptyMVar
|
||||
history <- newTVarIO ([],[])
|
||||
|
||||
builder <- builderNew
|
||||
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
|
||||
@ -160,13 +114,34 @@ createMyView mygui nb iofmv = do
|
||||
|
||||
urlBar <- builderGetObject builder castToEntry
|
||||
"urlBar"
|
||||
|
||||
backViewB <- builderGetObject builder castToButton
|
||||
"backViewB"
|
||||
rcMenu <- builderGetObject builder castToMenu
|
||||
"rcMenu"
|
||||
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"
|
||||
forwardViewB <- builderGetObject builder castToButton
|
||||
"forwardViewB"
|
||||
homeViewB <- builderGetObject builder castToButton
|
||||
"homeViewB"
|
||||
refreshViewB <- builderGetObject builder castToButton
|
||||
@ -176,7 +151,7 @@ createMyView mygui nb iofmv = do
|
||||
viewBox <- builderGetObject builder castToBox
|
||||
"viewBox"
|
||||
|
||||
let notebook = nb
|
||||
let rcmenu = MkRightClickMenu {..}
|
||||
let myview = MkMyView {..}
|
||||
|
||||
-- set the bindings
|
||||
@ -197,38 +172,37 @@ switchView :: MyGUI -> MyView -> IO FMView -> IO ()
|
||||
switchView mygui myview iofmv = do
|
||||
cwd <- getCurrentDir myview
|
||||
|
||||
let nb = notebook myview
|
||||
|
||||
oldpage <- destroyView myview
|
||||
oldpage <- destroyView mygui myview
|
||||
|
||||
-- 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)
|
||||
notebookSetCurrentPage nb page
|
||||
|
||||
refreshView mygui nview cwd
|
||||
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.
|
||||
--
|
||||
-- Everything that needs to be done in order to forget about a
|
||||
-- view needs to be done here.
|
||||
--
|
||||
-- Returns the page in the tab list this view corresponds to.
|
||||
destroyView :: MyView -> IO Int
|
||||
destroyView myview = do
|
||||
destroyView :: MyGUI -> MyView -> IO Int
|
||||
destroyView mygui myview = do
|
||||
-- disconnect watcher
|
||||
mi <- tryTakeMVar (inotify myview)
|
||||
for_ mi $ \i -> killINotify i
|
||||
|
||||
page <- fromJust <$> notebookPageNum (notebook myview) (viewBox myview)
|
||||
page <- notebookGetCurrentPage (notebook mygui)
|
||||
|
||||
-- destroy old view and tab page
|
||||
view' <- readTVarIO $ view myview
|
||||
widgetDestroy (fmViewToContainer view')
|
||||
notebookRemovePage (notebook myview) page
|
||||
notebookRemovePage (notebook mygui) page
|
||||
|
||||
return page
|
||||
|
||||
@ -304,18 +278,44 @@ createTreeView = do
|
||||
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.
|
||||
--
|
||||
-- Throws:
|
||||
--
|
||||
-- - `userError` on inappropriate type
|
||||
refreshView :: MyGUI
|
||||
-- If the directory is not a Dir or a Symlink pointing to a Dir, then
|
||||
-- calls `refreshView` with the 3rd argument being Nothing.
|
||||
refreshView' :: MyGUI
|
||||
-> MyView
|
||||
-> Item
|
||||
-> IO ()
|
||||
refreshView mygui myview SymLink { sdest = Just d@Dir{} } =
|
||||
refreshView mygui myview d
|
||||
refreshView mygui myview item@Dir{} = do
|
||||
refreshView' mygui myview item@(DirOrSym _) = do
|
||||
newRawModel <- fileListStore item myview
|
||||
writeTVarIO (rawModel myview) newRawModel
|
||||
|
||||
@ -330,6 +330,12 @@ refreshView mygui myview item@Dir{} = do
|
||||
|
||||
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
|
||||
-- TODO: not implemented for icon view yet
|
||||
case view' of
|
||||
@ -338,7 +344,8 @@ refreshView mygui myview item@Dir{} = do
|
||||
ntps <- mapM treeRowReferenceGetPath trs
|
||||
mapM_ (treeSelectionSelectPath tvs) ntps
|
||||
_ -> 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,
|
||||
@ -363,14 +370,14 @@ constructView mygui myview = do
|
||||
dirtreePix FileLike{} = filePix
|
||||
dirtreePix DirSym{} = folderSymPix
|
||||
dirtreePix FileLikeSym{} = fileSymPix
|
||||
dirtreePix Failed{} = errorPix
|
||||
dirtreePix BrokenSymlink{} = errorPix
|
||||
dirtreePix _ = errorPix
|
||||
|
||||
|
||||
view' <- readTVarIO $ view myview
|
||||
|
||||
cdir <- getCurrentDir myview
|
||||
let cdirp = path cdir
|
||||
cdirp <- path <$> getCurrentDir myview
|
||||
|
||||
-- update urlBar
|
||||
entrySetText (urlBar myview) (P.fromAbs cdirp)
|
||||
@ -385,7 +392,7 @@ constructView mygui myview = do
|
||||
item <- treeModelGetRow rawModel' iter >>= (P.basename . path)
|
||||
if hidden
|
||||
then return True
|
||||
else return . not . hiddenFile . P.fromRel $ item
|
||||
else return $ not . P.hiddenFile $ item
|
||||
|
||||
-- sorting
|
||||
sortedModel' <- treeModelSortNewWithModel filteredModel'
|
||||
@ -411,7 +418,7 @@ constructView mygui myview = do
|
||||
-- update model of view
|
||||
case view' of
|
||||
FMTreeView treeView -> do
|
||||
treeViewSetModel treeView (Just sortedModel')
|
||||
treeViewSetModel treeView sortedModel'
|
||||
treeViewSetRubberBanding treeView True
|
||||
FMIconView iconView -> do
|
||||
iconViewSetModel iconView (Just sortedModel')
|
||||
@ -428,7 +435,7 @@ constructView mygui myview = do
|
||||
newi
|
||||
[Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
|
||||
(P.fromAbs cdirp)
|
||||
(\_ -> postGUIAsync $ refreshView mygui myview cdir)
|
||||
(\_ -> postGUIAsync $ refreshView mygui myview (Just $ cdirp))
|
||||
putMVar (inotify myview) newi
|
||||
|
||||
return ()
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -78,8 +78,8 @@ withItems :: MyGUI
|
||||
-> ( [Item]
|
||||
-> MyGUI
|
||||
-> MyView
|
||||
-> IO a) -- ^ action to carry out
|
||||
-> IO a
|
||||
-> IO ()) -- ^ action to carry out
|
||||
-> IO ()
|
||||
withItems mygui myview io = do
|
||||
items <- getSelectedItems mygui myview
|
||||
io items mygui myview
|
||||
@ -152,3 +152,15 @@ rawPathToItem myview tp = do
|
||||
miter <- rawPathToIter myview tp
|
||||
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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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")
|
||||
|
||||
139
src/HSFM/Settings/Bookmarks.hs
Normal file
139
src/HSFM/Settings/Bookmarks.hs
Normal file
@ -0,0 +1,139 @@
|
||||
{--
|
||||
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 #-}
|
||||
{-# OPTIONS_HADDOCK ignore-exports #-}
|
||||
|
||||
module HSFM.Settings.Bookmarks where
|
||||
|
||||
|
||||
import Control.Monad
|
||||
(
|
||||
void
|
||||
)
|
||||
import Data.Attoparsec.ByteString
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.ByteString
|
||||
(
|
||||
ByteString
|
||||
)
|
||||
import Data.Maybe
|
||||
(
|
||||
catMaybes
|
||||
, fromJust
|
||||
)
|
||||
import Data.Word8
|
||||
(
|
||||
_nul
|
||||
)
|
||||
import qualified HPath as P
|
||||
import HPath
|
||||
(
|
||||
Abs
|
||||
, Fn
|
||||
, Path
|
||||
)
|
||||
import HSFM.FileSystem.FileOperations
|
||||
import HSFM.FileSystem.FileType
|
||||
import Prelude hiding (readFile, writeFile)
|
||||
import System.Posix.Env.ByteString
|
||||
(
|
||||
getEnv
|
||||
)
|
||||
|
||||
|
||||
|
||||
-- |A bookmark. `bkName` is principally a description of the bookmark
|
||||
-- but must satisfy the constraints of a filename.
|
||||
data Bookmark = MkBookmark {
|
||||
bkName :: Path Fn
|
||||
, bkPath :: Path Abs
|
||||
} deriving (Show)
|
||||
|
||||
|
||||
-- |Parses bookmarks from a ByteString that has pairs of
|
||||
-- name and path. Name and path are separated by one null character
|
||||
-- and the pairs itself are separated by two null characters from
|
||||
-- each other.
|
||||
bkParser :: Parser [Bookmark]
|
||||
bkParser =
|
||||
fmap catMaybes $ many' (fmap toBm $ bookmark <* word8 _nul <* word8 _nul)
|
||||
where
|
||||
toBm :: (ByteString, ByteString) -> Maybe Bookmark
|
||||
toBm (name, path) = MkBookmark <$> P.parseFn name
|
||||
<*> P.parseAbs path
|
||||
bookmark :: Parser (ByteString, ByteString)
|
||||
bookmark =
|
||||
(\x y -> (BS.pack x, BS.pack y))
|
||||
<$> many1' char
|
||||
<* (word8 _nul)
|
||||
<*> many1' char
|
||||
char = satisfy (`notElem` [_nul])
|
||||
|
||||
|
||||
-- |Writes bookmarks to a given file.
|
||||
writeBookmarks :: [Bookmark] -> IO ()
|
||||
writeBookmarks [] = return ()
|
||||
writeBookmarks bs = do
|
||||
bf <- bookmarksFile
|
||||
bfd <- bookmarksDir
|
||||
mkdirP bfd
|
||||
readFile getFileInfo bfd >>= (\x -> createFile x bookmarksFileName)
|
||||
let str = foldr1 (\x y -> x `BS.append` BS.pack [_nul, _nul]
|
||||
`BS.append`
|
||||
y `BS.append` BS.pack [_nul, _nul])
|
||||
(fmap toByteString bs)
|
||||
file <- readFile getFileInfo bf
|
||||
void $ writeFile file str
|
||||
where
|
||||
toByteString :: Bookmark -> ByteString
|
||||
toByteString b = (P.fromRel $ bkName b)
|
||||
`BS.append` BS.singleton _nul
|
||||
`BS.append` (P.fromAbs $ bkPath b)
|
||||
|
||||
|
||||
-- |Reads bookmarks from a given file.
|
||||
readBookmarks :: IO [Bookmark]
|
||||
readBookmarks = do
|
||||
p <- bookmarksFile
|
||||
file <- readFile getFileInfo p
|
||||
c <- readFileContents file
|
||||
case parseOnly bkParser c of
|
||||
Left _ -> return []
|
||||
Right x -> return x
|
||||
|
||||
|
||||
bookmarksDir :: IO (Path Abs)
|
||||
bookmarksDir = do
|
||||
mhomedir <- getEnv "HOME"
|
||||
case mhomedir of
|
||||
Nothing -> ioError (userError "No valid homedir?!")
|
||||
Just home -> do
|
||||
phome <- P.parseAbs home
|
||||
reldir <- P.parseRel ".config/hsfm"
|
||||
return $ phome P.</> reldir
|
||||
|
||||
|
||||
bookmarksFile :: IO (Path Abs)
|
||||
bookmarksFile = do
|
||||
path <- bookmarksDir
|
||||
return $ path P.</> bookmarksFileName
|
||||
|
||||
|
||||
bookmarksFileName :: Path Fn
|
||||
bookmarksFileName = fromJust $ P.parseFn "bookmarks"
|
||||
@ -33,6 +33,11 @@ import Control.Concurrent.STM.TVar
|
||||
, modifyTVar
|
||||
, TVar
|
||||
)
|
||||
import Control.Monad
|
||||
(
|
||||
when
|
||||
, unless
|
||||
)
|
||||
|
||||
|
||||
-- |Atomically write a TVar.
|
||||
@ -44,3 +49,14 @@ writeTVarIO tvar val = atomically $ writeTVar tvar val
|
||||
modifyTVarIO :: TVar a -> (a -> a) -> IO ()
|
||||
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)
|
||||
|
||||
@ -19,6 +19,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
||||
module HSFM.Utils.MyPrelude where
|
||||
|
||||
|
||||
import Data.Default
|
||||
import Data.List
|
||||
|
||||
|
||||
@ -30,3 +31,6 @@ listIndices :: [a] -> [Int]
|
||||
listIndices = findIndices (const True)
|
||||
|
||||
|
||||
-- |A `maybe` flavor using the `Default` class.
|
||||
maybeD :: (Default b) => (a -> b) -> Maybe a -> b
|
||||
maybeD = maybe def
|
||||
|
||||
@ -1,52 +0,0 @@
|
||||
#!/bin/bash
|
||||
|
||||
SOURCE_BRANCH="master"
|
||||
TARGET_BRANCH="gh-pages"
|
||||
REPO="https://${GH_TOKEN}@github.com/hasufell/hsfm"
|
||||
DOC_LOCATION="/dist/doc/html/hsfm/hsfm-gtk"
|
||||
|
||||
|
||||
# Pull requests and commits to other branches shouldn't try to deploy,
|
||||
# just build to verify
|
||||
if [ "$TRAVIS_PULL_REQUEST" != "false" -o "$TRAVIS_BRANCH" != "$SOURCE_BRANCH" ]; then
|
||||
echo "Skipping docs deploy."
|
||||
exit 0
|
||||
fi
|
||||
|
||||
|
||||
cd "$HOME"
|
||||
git config --global user.email "travis@travis-ci.org"
|
||||
git config --global user.name "travis-ci"
|
||||
git clone --branch=${TARGET_BRANCH} ${REPO} ${TARGET_BRANCH} || exit 1
|
||||
|
||||
# docs
|
||||
cd ${TARGET_BRANCH} || exit 1
|
||||
echo "Removing old docs."
|
||||
rm -rf *
|
||||
echo "Adding new docs."
|
||||
cp -rf "${TRAVIS_BUILD_DIR}${DOC_LOCATION}"/* . || exit 1
|
||||
|
||||
# If there are no changes to the compiled out (e.g. this is a README update)
|
||||
# then just bail.
|
||||
if [ -z "`git diff --exit-code`" ]; then
|
||||
echo "No changes to the output on this push; exiting."
|
||||
exit 0
|
||||
fi
|
||||
|
||||
git add -- .
|
||||
|
||||
if [[ -e ./index.html ]] ; then
|
||||
echo "Commiting docs."
|
||||
git commit -m "Lastest docs updated
|
||||
|
||||
travis build: $TRAVIS_BUILD_NUMBER
|
||||
commit: $TRAVIS_COMMIT
|
||||
auto-pushed to gh-pages"
|
||||
|
||||
git push origin $TARGET_BRANCH
|
||||
echo "Published docs to gh-pages."
|
||||
else
|
||||
echo "Error: docs are empty."
|
||||
exit 1
|
||||
fi
|
||||
|
||||
@ -1,66 +0,0 @@
|
||||
#!/usr/bin/env bash
|
||||
|
||||
set -eu
|
||||
|
||||
status_message() {
|
||||
printf "\\033[0;32m%s\\033[0m\\n" "$1"
|
||||
}
|
||||
|
||||
error_message() {
|
||||
printf "\\033[0;31m%s\\033[0m\\n" "$1"
|
||||
}
|
||||
|
||||
SCRIPTPATH="$( cd "$(dirname "$0")" ; pwd -P )"
|
||||
CACHE_LOCATION="${HOME}/.cabal/packages/hackage.haskell.org/01-index.cache"
|
||||
|
||||
if [ ! -f "${CACHE_LOCATION}" ] ; then
|
||||
error_message "${CACHE_LOCATION} does not exist, did you run 'cabal update'?"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
if [ ! -f "${SCRIPTPATH}/cabal.project" ] ; then
|
||||
error_message "Could not find ${SCRIPTPATH}/cabal.project, skipping index state update."
|
||||
exit 3
|
||||
fi
|
||||
|
||||
cabal v2-update
|
||||
|
||||
arch=$(getconf LONG_BIT)
|
||||
|
||||
case "${arch}" in
|
||||
32)
|
||||
byte_size=4
|
||||
magic_word="CABA1002"
|
||||
;;
|
||||
64)
|
||||
byte_size=8
|
||||
magic_word="00000000CABA1002"
|
||||
;;
|
||||
*)
|
||||
error_message "Unknown architecture (long bit): ${arch}"
|
||||
exit 2
|
||||
;;
|
||||
esac
|
||||
|
||||
# This is the logic to parse the binary format of 01-index.cache.
|
||||
# The first word is a magic 'caba1002', the second one is the timestamp in unix epoch.
|
||||
# Better than copying the cabal-install source code.
|
||||
if [ "$(xxd -u -p -l${byte_size} -s 0 "${CACHE_LOCATION}")" != "${magic_word}" ] ; then
|
||||
error_message "Magic word does not match!"
|
||||
exit 4
|
||||
fi
|
||||
cache_timestamp=$(echo "ibase=16;obase=A;$(xxd -u -p -l${byte_size} -s ${byte_size} "${CACHE_LOCATION}")" | bc)
|
||||
|
||||
# If we got junk from the binary file, this should fail.
|
||||
cache_date=$(date --utc --date "@${cache_timestamp}" "+%FT%TZ")
|
||||
|
||||
|
||||
status_message "Updating index state in ${SCRIPTPATH}/cabal.project"
|
||||
|
||||
if grep -q "^index-state: .*" "${SCRIPTPATH}/cabal.project" ; then
|
||||
awk '/index-state:/ {gsub(/.*/, "index-state: '${cache_date}'")}; { print }' "${SCRIPTPATH}/cabal.project" > "${SCRIPTPATH}/cabal.project.tmp"
|
||||
mv "${SCRIPTPATH}/cabal.project.tmp" "${SCRIPTPATH}/cabal.project"
|
||||
else
|
||||
printf "index-state: %s\n" "${cache_date}" >> "${SCRIPTPATH}/cabal.project"
|
||||
fi
|
||||
|
||||
Loading…
Reference in New Issue
Block a user